1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subecripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field. */
162 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
166 type = TREE_TYPE (desc);
167 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
169 field = TYPE_FIELDS (type);
170 gcc_assert (DATA_FIELD == 0);
172 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
173 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
177 /* This provides address access to the data field. This should only be
178 used by array allocation, passing this on to the runtime. */
181 gfc_conv_descriptor_data_addr (tree desc)
185 type = TREE_TYPE (desc);
186 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
188 field = TYPE_FIELDS (type);
189 gcc_assert (DATA_FIELD == 0);
191 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
192 return build_fold_addr_expr (t);
196 gfc_conv_descriptor_offset (tree desc)
201 type = TREE_TYPE (desc);
202 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
204 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
205 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
207 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
211 gfc_conv_descriptor_dtype (tree desc)
216 type = TREE_TYPE (desc);
217 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
219 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
220 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
222 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
226 gfc_conv_descriptor_dimension (tree desc, tree dim)
232 type = TREE_TYPE (desc);
233 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
235 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
236 gcc_assert (field != NULL_TREE
237 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
238 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
240 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
241 tmp = gfc_build_array_ref (tmp, dim);
246 gfc_conv_descriptor_stride (tree desc, tree dim)
251 tmp = gfc_conv_descriptor_dimension (desc, dim);
252 field = TYPE_FIELDS (TREE_TYPE (tmp));
253 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
254 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
256 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
261 gfc_conv_descriptor_lbound (tree desc, tree dim)
266 tmp = gfc_conv_descriptor_dimension (desc, dim);
267 field = TYPE_FIELDS (TREE_TYPE (tmp));
268 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
269 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
271 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
276 gfc_conv_descriptor_ubound (tree desc, tree dim)
281 tmp = gfc_conv_descriptor_dimension (desc, dim);
282 field = TYPE_FIELDS (TREE_TYPE (tmp));
283 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
284 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
286 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
291 /* Build a null array descriptor constructor. */
294 gfc_build_null_descriptor (tree type)
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
300 gcc_assert (DATA_FIELD == 0);
301 field = TYPE_FIELDS (type);
303 /* Set a NULL data pointer. */
304 tmp = build_constructor_single (type, field, null_pointer_node);
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)
365 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
367 if (ss->data.info.subscript[n])
368 gfc_free_ss_chain (ss->data.info.subscript[n]);
380 /* Free all the SS associated with a loop. */
383 gfc_cleanup_loop (gfc_loopinfo * loop)
389 while (ss != gfc_ss_terminator)
391 gcc_assert (ss != NULL);
392 next = ss->loop_chain;
399 /* Associate a SS chain with a loop. */
402 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
406 if (head == gfc_ss_terminator)
410 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
412 if (ss->next == gfc_ss_terminator)
413 ss->loop_chain = loop->ss;
415 ss->loop_chain = ss->next;
417 gcc_assert (ss == gfc_ss_terminator);
422 /* Generate an initializer for a static pointer or allocatable array. */
425 gfc_trans_static_array_pointer (gfc_symbol * sym)
429 gcc_assert (TREE_STATIC (sym->backend_decl));
430 /* Just zero the data member. */
431 type = TREE_TYPE (sym->backend_decl);
432 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
436 /* If the bounds of SE's loop have not yet been set, see if they can be
437 determined from array spec AS, which is the array spec of a called
438 function. MAPPING maps the callee's dummy arguments to the values
439 that the caller is passing. Add any initialization and finalization
443 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
444 gfc_se * se, gfc_array_spec * as)
452 if (as && as->type == AS_EXPLICIT)
453 for (dim = 0; dim < se->loop->dimen; dim++)
455 n = se->loop->order[dim];
456 if (se->loop->to[n] == NULL_TREE)
458 /* Evaluate the lower bound. */
459 gfc_init_se (&tmpse, NULL);
460 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
461 gfc_add_block_to_block (&se->pre, &tmpse.pre);
462 gfc_add_block_to_block (&se->post, &tmpse.post);
465 /* ...and the upper bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* Set the upper bound of the loop to UPPER - LOWER. */
473 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
474 tmp = gfc_evaluate_now (tmp, &se->pre);
475 se->loop->to[n] = tmp;
481 /* Generate code to allocate an array temporary, or create a variable to
482 hold the data. If size is NULL, zero the descriptor so that the
483 callee will allocate the array. If DEALLOC is true, also generate code to
484 free the array afterwards.
486 Initialization code is added to PRE and finalization code to POST.
487 DYNAMIC is true if the caller may want to extend the array later
488 using realloc. This prevents us from putting the array on the stack. */
491 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
492 gfc_ss_info * info, tree size, tree nelem,
493 bool dynamic, bool dealloc)
500 desc = info->descriptor;
501 info->offset = gfc_index_zero_node;
502 if (size == NULL_TREE || integer_zerop (size))
504 /* A callee allocated array. */
505 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
510 /* Allocate the temporary. */
511 onstack = !dynamic && gfc_can_put_var_on_stack (size);
515 /* Make a temporary variable to hold the data. */
516 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
518 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
520 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
522 tmp = gfc_create_var (tmp, "A");
523 tmp = build_fold_addr_expr (tmp);
524 gfc_conv_descriptor_data_set (pre, desc, tmp);
528 /* Allocate memory to hold the data. */
529 args = gfc_chainon_list (NULL_TREE, size);
531 if (gfc_index_integer_kind == 4)
532 tmp = gfor_fndecl_internal_malloc;
533 else if (gfc_index_integer_kind == 8)
534 tmp = gfor_fndecl_internal_malloc64;
537 tmp = build_function_call_expr (tmp, args);
538 tmp = gfc_evaluate_now (tmp, pre);
539 gfc_conv_descriptor_data_set (pre, desc, tmp);
542 info->data = gfc_conv_descriptor_data_get (desc);
544 /* The offset is zero because we create temporaries with a zero
546 tmp = gfc_conv_descriptor_offset (desc);
547 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
549 if (dealloc && !onstack)
551 /* Free the temporary. */
552 tmp = gfc_conv_descriptor_data_get (desc);
553 tmp = fold_convert (pvoid_type_node, tmp);
554 tmp = gfc_chainon_list (NULL_TREE, tmp);
555 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
556 gfc_add_expr_to_block (post, tmp);
561 /* Generate code to create and initialize the descriptor for a temporary
562 array. This is used for both temporaries needed by the scalarizer, and
563 functions returning arrays. Adjusts the loop variables to be
564 zero-based, and calculates the loop bounds for callee allocated arrays.
565 Allocate the array unless it's callee allocated (we have a callee
566 allocated array if 'callee_alloc' is true, or if loop->to[n] is
567 NULL_TREE for any n). Also fills in the descriptor, data and offset
568 fields of info if known. Returns the size of the array, or NULL for a
569 callee allocated array.
571 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
575 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
576 gfc_loopinfo * loop, gfc_ss_info * info,
577 tree eltype, bool dynamic, bool dealloc,
578 bool callee_alloc, bool function)
590 stmtblock_t thenblock;
591 stmtblock_t elseblock;
595 gcc_assert (info->dimen > 0);
596 /* Set the lower bound to zero. */
597 for (dim = 0; dim < info->dimen; dim++)
599 n = loop->order[dim];
600 if (n < loop->temp_dim)
601 gcc_assert (integer_zerop (loop->from[n]));
604 /* Callee allocated arrays may not have a known bound yet. */
606 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
607 loop->to[n], loop->from[n]);
608 loop->from[n] = gfc_index_zero_node;
611 info->delta[dim] = gfc_index_zero_node;
612 info->start[dim] = gfc_index_zero_node;
613 info->stride[dim] = gfc_index_one_node;
614 info->dim[dim] = dim;
617 /* Initialize the descriptor. */
619 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
620 desc = gfc_create_var (type, "atmp");
621 GFC_DECL_PACKED_ARRAY (desc) = 1;
623 info->descriptor = desc;
624 size = gfc_index_one_node;
626 /* Fill in the array dtype. */
627 tmp = gfc_conv_descriptor_dtype (desc);
628 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
631 Fill in the bounds and stride. This is a packed array, so:
634 for (n = 0; n < rank; n++)
637 delta = ubound[n] + 1 - lbound[n];
640 size = size * sizeof(element);
645 for (n = 0; n < info->dimen; n++)
647 if (loop->to[n] == NULL_TREE)
649 /* For a callee allocated array express the loop bounds in terms
650 of the descriptor fields. */
651 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
652 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
653 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
659 /* Store the stride and bound components in the descriptor. */
660 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
661 gfc_add_modify_expr (pre, tmp, size);
663 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
664 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
666 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
667 gfc_add_modify_expr (pre, tmp, loop->to[n]);
669 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
670 loop->to[n], gfc_index_one_node);
674 /* Check wether the size for this dimension is negative. */
675 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
676 gfc_index_zero_node);
678 cond = gfc_evaluate_now (cond, pre);
683 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
685 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
686 size = gfc_evaluate_now (size, pre);
689 /* Get the size of the array. */
691 if (size && !callee_alloc)
695 var = gfc_create_var (TREE_TYPE (size), "size");
696 gfc_start_block (&thenblock);
697 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
698 thencase = gfc_finish_block (&thenblock);
700 gfc_start_block (&elseblock);
701 gfc_add_modify_expr (&elseblock, var, size);
702 elsecase = gfc_finish_block (&elseblock);
704 tmp = gfc_evaluate_now (or_expr, pre);
705 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
706 gfc_add_expr_to_block (pre, tmp);
713 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
714 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
722 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
725 if (info->dimen > loop->temp_dim)
726 loop->temp_dim = info->dimen;
732 /* Generate code to transpose array EXPR by creating a new descriptor
733 in which the dimension specifications have been reversed. */
736 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
738 tree dest, src, dest_index, src_index;
740 gfc_ss_info *dest_info, *src_info;
741 gfc_ss *dest_ss, *src_ss;
747 src_ss = gfc_walk_expr (expr);
750 src_info = &src_ss->data.info;
751 dest_info = &dest_ss->data.info;
752 gcc_assert (dest_info->dimen == 2);
753 gcc_assert (src_info->dimen == 2);
755 /* Get a descriptor for EXPR. */
756 gfc_init_se (&src_se, NULL);
757 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
758 gfc_add_block_to_block (&se->pre, &src_se.pre);
759 gfc_add_block_to_block (&se->post, &src_se.post);
762 /* Allocate a new descriptor for the return value. */
763 dest = gfc_create_var (TREE_TYPE (src), "atmp");
764 dest_info->descriptor = dest;
767 /* Copy across the dtype field. */
768 gfc_add_modify_expr (&se->pre,
769 gfc_conv_descriptor_dtype (dest),
770 gfc_conv_descriptor_dtype (src));
772 /* Copy the dimension information, renumbering dimension 1 to 0 and
774 for (n = 0; n < 2; n++)
776 dest_info->delta[n] = gfc_index_zero_node;
777 dest_info->start[n] = gfc_index_zero_node;
778 dest_info->stride[n] = gfc_index_one_node;
779 dest_info->dim[n] = n;
781 dest_index = gfc_rank_cst[n];
782 src_index = gfc_rank_cst[1 - n];
784 gfc_add_modify_expr (&se->pre,
785 gfc_conv_descriptor_stride (dest, dest_index),
786 gfc_conv_descriptor_stride (src, src_index));
788 gfc_add_modify_expr (&se->pre,
789 gfc_conv_descriptor_lbound (dest, dest_index),
790 gfc_conv_descriptor_lbound (src, src_index));
792 gfc_add_modify_expr (&se->pre,
793 gfc_conv_descriptor_ubound (dest, dest_index),
794 gfc_conv_descriptor_ubound (src, src_index));
798 gcc_assert (integer_zerop (loop->from[n]));
799 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
800 gfc_conv_descriptor_ubound (dest, dest_index),
801 gfc_conv_descriptor_lbound (dest, dest_index));
805 /* Copy the data pointer. */
806 dest_info->data = gfc_conv_descriptor_data_get (src);
807 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
809 /* Copy the offset. This is not changed by transposition: the top-left
810 element is still at the same offset as before. */
811 dest_info->offset = gfc_conv_descriptor_offset (src);
812 gfc_add_modify_expr (&se->pre,
813 gfc_conv_descriptor_offset (dest),
816 if (dest_info->dimen > loop->temp_dim)
817 loop->temp_dim = dest_info->dimen;
821 /* Return the number of iterations in a loop that starts at START,
822 ends at END, and has step STEP. */
825 gfc_get_iteration_count (tree start, tree end, tree step)
830 type = TREE_TYPE (step);
831 tmp = fold_build2 (MINUS_EXPR, type, end, start);
832 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
833 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
834 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
835 return fold_convert (gfc_array_index_type, tmp);
839 /* Extend the data in array DESC by EXTRA elements. */
842 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
849 if (integer_zerop (extra))
852 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
854 /* Add EXTRA to the upper bound. */
855 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
856 gfc_add_modify_expr (pblock, ubound, tmp);
858 /* Get the value of the current data pointer. */
859 tmp = gfc_conv_descriptor_data_get (desc);
860 args = gfc_chainon_list (NULL_TREE, tmp);
862 /* Calculate the new array size. */
863 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
864 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
865 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
866 args = gfc_chainon_list (args, tmp);
868 /* Pick the appropriate realloc function. */
869 if (gfc_index_integer_kind == 4)
870 tmp = gfor_fndecl_internal_realloc;
871 else if (gfc_index_integer_kind == 8)
872 tmp = gfor_fndecl_internal_realloc64;
876 /* Set the new data pointer. */
877 tmp = build_function_call_expr (tmp, args);
878 gfc_conv_descriptor_data_set (pblock, desc, tmp);
882 /* Return true if the bounds of iterator I can only be determined
886 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
888 return (i->start->expr_type != EXPR_CONSTANT
889 || i->end->expr_type != EXPR_CONSTANT
890 || i->step->expr_type != EXPR_CONSTANT);
894 /* Split the size of constructor element EXPR into the sum of two terms,
895 one of which can be determined at compile time and one of which must
896 be calculated at run time. Set *SIZE to the former and return true
897 if the latter might be nonzero. */
900 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
902 if (expr->expr_type == EXPR_ARRAY)
903 return gfc_get_array_constructor_size (size, expr->value.constructor);
904 else if (expr->rank > 0)
906 /* Calculate everything at run time. */
907 mpz_set_ui (*size, 0);
912 /* A single element. */
913 mpz_set_ui (*size, 1);
919 /* Like gfc_get_array_constructor_element_size, but applied to the whole
920 of array constructor C. */
923 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
930 mpz_set_ui (*size, 0);
935 for (; c; c = c->next)
938 if (i && gfc_iterator_has_dynamic_bounds (i))
942 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
945 /* Multiply the static part of the element size by the
946 number of iterations. */
947 mpz_sub (val, i->end->value.integer, i->start->value.integer);
948 mpz_fdiv_q (val, val, i->step->value.integer);
949 mpz_add_ui (val, val, 1);
950 if (mpz_sgn (val) > 0)
951 mpz_mul (len, len, val);
955 mpz_add (*size, *size, len);
964 /* Make sure offset is a variable. */
967 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
970 /* We should have already created the offset variable. We cannot
971 create it here because we may be in an inner scope. */
972 gcc_assert (*offsetvar != NULL_TREE);
973 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
974 *poffset = *offsetvar;
975 TREE_USED (*offsetvar) = 1;
979 /* Assign an element of an array constructor. */
982 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
983 tree offset, gfc_se * se, gfc_expr * expr)
988 gfc_conv_expr (se, expr);
990 /* Store the value. */
991 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
992 tmp = gfc_build_array_ref (tmp, offset);
993 if (expr->ts.type == BT_CHARACTER)
995 gfc_conv_string_parameter (se);
996 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
998 /* The temporary is an array of pointers. */
999 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1000 gfc_add_modify_expr (&se->pre, tmp, se->expr);
1004 /* The temporary is an array of string values. */
1005 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
1006 /* We know the temporary and the value will be the same length,
1007 so can use memcpy. */
1008 args = gfc_chainon_list (NULL_TREE, tmp);
1009 args = gfc_chainon_list (args, se->expr);
1010 args = gfc_chainon_list (args, se->string_length);
1011 tmp = built_in_decls[BUILT_IN_MEMCPY];
1012 tmp = build_function_call_expr (tmp, args);
1013 gfc_add_expr_to_block (&se->pre, tmp);
1018 /* TODO: Should the frontend already have done this conversion? */
1019 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1020 gfc_add_modify_expr (&se->pre, tmp, se->expr);
1023 gfc_add_block_to_block (pblock, &se->pre);
1024 gfc_add_block_to_block (pblock, &se->post);
1028 /* Add the contents of an array to the constructor. DYNAMIC is as for
1029 gfc_trans_array_constructor_value. */
1032 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1033 tree type ATTRIBUTE_UNUSED,
1034 tree desc, gfc_expr * expr,
1035 tree * poffset, tree * offsetvar,
1046 /* We need this to be a variable so we can increment it. */
1047 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1049 gfc_init_se (&se, NULL);
1051 /* Walk the array expression. */
1052 ss = gfc_walk_expr (expr);
1053 gcc_assert (ss != gfc_ss_terminator);
1055 /* Initialize the scalarizer. */
1056 gfc_init_loopinfo (&loop);
1057 gfc_add_ss_to_loop (&loop, ss);
1059 /* Initialize the loop. */
1060 gfc_conv_ss_startstride (&loop);
1061 gfc_conv_loop_setup (&loop);
1063 /* Make sure the constructed array has room for the new data. */
1066 /* Set SIZE to the total number of elements in the subarray. */
1067 size = gfc_index_one_node;
1068 for (n = 0; n < loop.dimen; n++)
1070 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1071 gfc_index_one_node);
1072 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1075 /* Grow the constructed array by SIZE elements. */
1076 gfc_grow_array (&loop.pre, desc, size);
1079 /* Make the loop body. */
1080 gfc_mark_ss_chain_used (ss, 1);
1081 gfc_start_scalarized_body (&loop, &body);
1082 gfc_copy_loopinfo_to_se (&se, &loop);
1085 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1086 gcc_assert (se.ss == gfc_ss_terminator);
1088 /* Increment the offset. */
1089 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1090 gfc_add_modify_expr (&body, *poffset, tmp);
1092 /* Finish the loop. */
1093 gfc_trans_scalarizing_loops (&loop, &body);
1094 gfc_add_block_to_block (&loop.pre, &loop.post);
1095 tmp = gfc_finish_block (&loop.pre);
1096 gfc_add_expr_to_block (pblock, tmp);
1098 gfc_cleanup_loop (&loop);
1102 /* Assign the values to the elements of an array constructor. DYNAMIC
1103 is true if descriptor DESC only contains enough data for the static
1104 size calculated by gfc_get_array_constructor_size. When true, memory
1105 for the dynamic parts must be allocated using realloc. */
1108 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1109 tree desc, gfc_constructor * c,
1110 tree * poffset, tree * offsetvar,
1119 for (; c; c = c->next)
1121 /* If this is an iterator or an array, the offset must be a variable. */
1122 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1123 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1125 gfc_start_block (&body);
1127 if (c->expr->expr_type == EXPR_ARRAY)
1129 /* Array constructors can be nested. */
1130 gfc_trans_array_constructor_value (&body, type, desc,
1131 c->expr->value.constructor,
1132 poffset, offsetvar, dynamic);
1134 else if (c->expr->rank > 0)
1136 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1137 poffset, offsetvar, dynamic);
1141 /* This code really upsets the gimplifier so don't bother for now. */
1148 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1155 /* Scalar values. */
1156 gfc_init_se (&se, NULL);
1157 gfc_trans_array_ctor_element (&body, desc, *poffset,
1160 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1161 *poffset, gfc_index_one_node);
1165 /* Collect multiple scalar constants into a constructor. */
1173 /* Count the number of consecutive scalar constants. */
1174 while (p && !(p->iterator
1175 || p->expr->expr_type != EXPR_CONSTANT))
1177 gfc_init_se (&se, NULL);
1178 gfc_conv_constant (&se, p->expr);
1179 if (p->expr->ts.type == BT_CHARACTER
1180 && POINTER_TYPE_P (type))
1182 /* For constant character array constructors we build
1183 an array of pointers. */
1184 se.expr = gfc_build_addr_expr (pchar_type_node,
1188 list = tree_cons (NULL_TREE, se.expr, list);
1193 bound = build_int_cst (NULL_TREE, n - 1);
1194 /* Create an array type to hold them. */
1195 tmptype = build_range_type (gfc_array_index_type,
1196 gfc_index_zero_node, bound);
1197 tmptype = build_array_type (type, tmptype);
1199 init = build_constructor_from_list (tmptype, nreverse (list));
1200 TREE_CONSTANT (init) = 1;
1201 TREE_INVARIANT (init) = 1;
1202 TREE_STATIC (init) = 1;
1203 /* Create a static variable to hold the data. */
1204 tmp = gfc_create_var (tmptype, "data");
1205 TREE_STATIC (tmp) = 1;
1206 TREE_CONSTANT (tmp) = 1;
1207 TREE_INVARIANT (tmp) = 1;
1208 DECL_INITIAL (tmp) = init;
1211 /* Use BUILTIN_MEMCPY to assign the values. */
1212 tmp = gfc_conv_descriptor_data_get (desc);
1213 tmp = build_fold_indirect_ref (tmp);
1214 tmp = gfc_build_array_ref (tmp, *poffset);
1215 tmp = build_fold_addr_expr (tmp);
1216 init = build_fold_addr_expr (init);
1218 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1219 bound = build_int_cst (NULL_TREE, n * size);
1220 tmp = gfc_chainon_list (NULL_TREE, tmp);
1221 tmp = gfc_chainon_list (tmp, init);
1222 tmp = gfc_chainon_list (tmp, bound);
1223 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1225 gfc_add_expr_to_block (&body, tmp);
1227 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1228 *poffset, build_int_cst (NULL_TREE, n));
1230 if (!INTEGER_CST_P (*poffset))
1232 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1233 *poffset = *offsetvar;
1237 /* The frontend should already have done any expansions possible
1241 /* Pass the code as is. */
1242 tmp = gfc_finish_block (&body);
1243 gfc_add_expr_to_block (pblock, tmp);
1247 /* Build the implied do-loop. */
1256 loopbody = gfc_finish_block (&body);
1258 gfc_init_se (&se, NULL);
1259 gfc_conv_expr (&se, c->iterator->var);
1260 gfc_add_block_to_block (pblock, &se.pre);
1263 /* Initialize the loop. */
1264 gfc_init_se (&se, NULL);
1265 gfc_conv_expr_val (&se, c->iterator->start);
1266 gfc_add_block_to_block (pblock, &se.pre);
1267 gfc_add_modify_expr (pblock, loopvar, se.expr);
1269 gfc_init_se (&se, NULL);
1270 gfc_conv_expr_val (&se, c->iterator->end);
1271 gfc_add_block_to_block (pblock, &se.pre);
1272 end = gfc_evaluate_now (se.expr, pblock);
1274 gfc_init_se (&se, NULL);
1275 gfc_conv_expr_val (&se, c->iterator->step);
1276 gfc_add_block_to_block (pblock, &se.pre);
1277 step = gfc_evaluate_now (se.expr, pblock);
1279 /* If this array expands dynamically, and the number of iterations
1280 is not constant, we won't have allocated space for the static
1281 part of C->EXPR's size. Do that now. */
1282 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1284 /* Get the number of iterations. */
1285 tmp = gfc_get_iteration_count (loopvar, end, step);
1287 /* Get the static part of C->EXPR's size. */
1288 gfc_get_array_constructor_element_size (&size, c->expr);
1289 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1291 /* Grow the array by TMP * TMP2 elements. */
1292 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1293 gfc_grow_array (pblock, desc, tmp);
1296 /* Generate the loop body. */
1297 exit_label = gfc_build_label_decl (NULL_TREE);
1298 gfc_start_block (&body);
1300 /* Generate the exit condition. Depending on the sign of
1301 the step variable we have to generate the correct
1303 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1304 build_int_cst (TREE_TYPE (step), 0));
1305 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1306 build2 (GT_EXPR, boolean_type_node,
1308 build2 (LT_EXPR, boolean_type_node,
1310 tmp = build1_v (GOTO_EXPR, exit_label);
1311 TREE_USED (exit_label) = 1;
1312 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1313 gfc_add_expr_to_block (&body, tmp);
1315 /* The main loop body. */
1316 gfc_add_expr_to_block (&body, loopbody);
1318 /* Increase loop variable by step. */
1319 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1320 gfc_add_modify_expr (&body, loopvar, tmp);
1322 /* Finish the loop. */
1323 tmp = gfc_finish_block (&body);
1324 tmp = build1_v (LOOP_EXPR, tmp);
1325 gfc_add_expr_to_block (pblock, tmp);
1327 /* Add the exit label. */
1328 tmp = build1_v (LABEL_EXPR, exit_label);
1329 gfc_add_expr_to_block (pblock, tmp);
1336 /* Figure out the string length of a variable reference expression.
1337 Used by get_array_ctor_strlen. */
1340 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1346 /* Don't bother if we already know the length is a constant. */
1347 if (*len && INTEGER_CST_P (*len))
1350 ts = &expr->symtree->n.sym->ts;
1351 for (ref = expr->ref; ref; ref = ref->next)
1356 /* Array references don't change the string length. */
1360 /* Use the length of the component. */
1361 ts = &ref->u.c.component->ts;
1365 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1366 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1368 mpz_init_set_ui (char_len, 1);
1369 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1370 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1371 *len = gfc_conv_mpz_to_tree (char_len,
1372 gfc_default_character_kind);
1373 *len = convert (gfc_charlen_type_node, *len);
1374 mpz_clear (char_len);
1378 /* TODO: Substrings are tricky because we can't evaluate the
1379 expression more than once. For now we just give up, and hope
1380 we can figure it out elsewhere. */
1385 *len = ts->cl->backend_decl;
1389 /* Figure out the string length of a character array constructor.
1390 Returns TRUE if all elements are character constants. */
1393 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1398 for (; c; c = c->next)
1400 switch (c->expr->expr_type)
1403 if (!(*len && INTEGER_CST_P (*len)))
1404 *len = build_int_cstu (gfc_charlen_type_node,
1405 c->expr->value.character.length);
1409 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1415 get_array_ctor_var_strlen (c->expr, len);
1420 /* TODO: For now we just ignore anything we don't know how to
1421 handle, and hope we can figure it out a different way. */
1430 /* Array constructors are handled by constructing a temporary, then using that
1431 within the scalarization loop. This is not optimal, but seems by far the
1435 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1445 ss->data.info.dimen = loop->dimen;
1447 c = ss->expr->value.constructor;
1448 if (ss->expr->ts.type == BT_CHARACTER)
1450 const_string = get_array_ctor_strlen (c, &ss->string_length);
1451 if (!ss->string_length)
1452 gfc_todo_error ("complex character array constructors");
1454 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1456 type = build_pointer_type (type);
1460 const_string = TRUE;
1461 type = gfc_typenode_for_spec (&ss->expr->ts);
1464 /* See if the constructor determines the loop bounds. */
1466 if (loop->to[0] == NULL_TREE)
1470 /* We should have a 1-dimensional, zero-based loop. */
1471 gcc_assert (loop->dimen == 1);
1472 gcc_assert (integer_zerop (loop->from[0]));
1474 /* Split the constructor size into a static part and a dynamic part.
1475 Allocate the static size up-front and record whether the dynamic
1476 size might be nonzero. */
1478 dynamic = gfc_get_array_constructor_size (&size, c);
1479 mpz_sub_ui (size, size, 1);
1480 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1484 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1485 type, dynamic, true, false, false);
1487 desc = ss->data.info.descriptor;
1488 offset = gfc_index_zero_node;
1489 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1490 TREE_USED (offsetvar) = 0;
1491 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1492 &offset, &offsetvar, dynamic);
1494 /* If the array grows dynamically, the upper bound of the loop variable
1495 is determined by the array's final upper bound. */
1497 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1499 if (TREE_USED (offsetvar))
1500 pushdecl (offsetvar);
1502 gcc_assert (INTEGER_CST_P (offset));
1504 /* Disable bound checking for now because it's probably broken. */
1505 if (flag_bounds_check)
1513 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1514 called after evaluating all of INFO's vector dimensions. Go through
1515 each such vector dimension and see if we can now fill in any missing
1519 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1528 for (n = 0; n < loop->dimen; n++)
1531 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1532 && loop->to[n] == NULL)
1534 /* Loop variable N indexes vector dimension DIM, and we don't
1535 yet know the upper bound of loop variable N. Set it to the
1536 difference between the vector's upper and lower bounds. */
1537 gcc_assert (loop->from[n] == gfc_index_zero_node);
1538 gcc_assert (info->subscript[dim]
1539 && info->subscript[dim]->type == GFC_SS_VECTOR);
1541 gfc_init_se (&se, NULL);
1542 desc = info->subscript[dim]->data.info.descriptor;
1543 zero = gfc_rank_cst[0];
1544 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1545 gfc_conv_descriptor_ubound (desc, zero),
1546 gfc_conv_descriptor_lbound (desc, zero));
1547 tmp = gfc_evaluate_now (tmp, &loop->pre);
1554 /* Add the pre and post chains for all the scalar expressions in a SS chain
1555 to loop. This is called after the loop parameters have been calculated,
1556 but before the actual scalarizing loops. */
1559 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1564 /* TODO: This can generate bad code if there are ordering dependencies.
1565 eg. a callee allocated function and an unknown size constructor. */
1566 gcc_assert (ss != NULL);
1568 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1575 /* Scalar expression. Evaluate this now. This includes elemental
1576 dimension indices, but not array section bounds. */
1577 gfc_init_se (&se, NULL);
1578 gfc_conv_expr (&se, ss->expr);
1579 gfc_add_block_to_block (&loop->pre, &se.pre);
1581 if (ss->expr->ts.type != BT_CHARACTER)
1583 /* Move the evaluation of scalar expressions outside the
1584 scalarization loop. */
1586 se.expr = convert(gfc_array_index_type, se.expr);
1587 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1588 gfc_add_block_to_block (&loop->pre, &se.post);
1591 gfc_add_block_to_block (&loop->post, &se.post);
1593 ss->data.scalar.expr = se.expr;
1594 ss->string_length = se.string_length;
1597 case GFC_SS_REFERENCE:
1598 /* Scalar reference. Evaluate this now. */
1599 gfc_init_se (&se, NULL);
1600 gfc_conv_expr_reference (&se, ss->expr);
1601 gfc_add_block_to_block (&loop->pre, &se.pre);
1602 gfc_add_block_to_block (&loop->post, &se.post);
1604 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1605 ss->string_length = se.string_length;
1608 case GFC_SS_SECTION:
1609 /* Add the expressions for scalar and vector subscripts. */
1610 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1611 if (ss->data.info.subscript[n])
1612 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1614 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1618 /* Get the vector's descriptor and store it in SS. */
1619 gfc_init_se (&se, NULL);
1620 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1621 gfc_add_block_to_block (&loop->pre, &se.pre);
1622 gfc_add_block_to_block (&loop->post, &se.post);
1623 ss->data.info.descriptor = se.expr;
1626 case GFC_SS_INTRINSIC:
1627 gfc_add_intrinsic_ss_code (loop, ss);
1630 case GFC_SS_FUNCTION:
1631 /* Array function return value. We call the function and save its
1632 result in a temporary for use inside the loop. */
1633 gfc_init_se (&se, NULL);
1636 gfc_conv_expr (&se, ss->expr);
1637 gfc_add_block_to_block (&loop->pre, &se.pre);
1638 gfc_add_block_to_block (&loop->post, &se.post);
1639 ss->string_length = se.string_length;
1642 case GFC_SS_CONSTRUCTOR:
1643 gfc_trans_array_constructor (loop, ss);
1647 case GFC_SS_COMPONENT:
1648 /* Do nothing. These are handled elsewhere. */
1658 /* Translate expressions for the descriptor and data pointer of a SS. */
1662 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1667 /* Get the descriptor for the array to be scalarized. */
1668 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1669 gfc_init_se (&se, NULL);
1670 se.descriptor_only = 1;
1671 gfc_conv_expr_lhs (&se, ss->expr);
1672 gfc_add_block_to_block (block, &se.pre);
1673 ss->data.info.descriptor = se.expr;
1674 ss->string_length = se.string_length;
1678 /* Also the data pointer. */
1679 tmp = gfc_conv_array_data (se.expr);
1680 /* If this is a variable or address of a variable we use it directly.
1681 Otherwise we must evaluate it now to avoid breaking dependency
1682 analysis by pulling the expressions for elemental array indices
1685 || (TREE_CODE (tmp) == ADDR_EXPR
1686 && DECL_P (TREE_OPERAND (tmp, 0)))))
1687 tmp = gfc_evaluate_now (tmp, block);
1688 ss->data.info.data = tmp;
1690 tmp = gfc_conv_array_offset (se.expr);
1691 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1696 /* Initialize a gfc_loopinfo structure. */
1699 gfc_init_loopinfo (gfc_loopinfo * loop)
1703 memset (loop, 0, sizeof (gfc_loopinfo));
1704 gfc_init_block (&loop->pre);
1705 gfc_init_block (&loop->post);
1707 /* Initially scalarize in order. */
1708 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1711 loop->ss = gfc_ss_terminator;
1715 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1719 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1725 /* Return an expression for the data pointer of an array. */
1728 gfc_conv_array_data (tree descriptor)
1732 type = TREE_TYPE (descriptor);
1733 if (GFC_ARRAY_TYPE_P (type))
1735 if (TREE_CODE (type) == POINTER_TYPE)
1739 /* Descriptorless arrays. */
1740 return build_fold_addr_expr (descriptor);
1744 return gfc_conv_descriptor_data_get (descriptor);
1748 /* Return an expression for the base offset of an array. */
1751 gfc_conv_array_offset (tree descriptor)
1755 type = TREE_TYPE (descriptor);
1756 if (GFC_ARRAY_TYPE_P (type))
1757 return GFC_TYPE_ARRAY_OFFSET (type);
1759 return gfc_conv_descriptor_offset (descriptor);
1763 /* Get an expression for the array stride. */
1766 gfc_conv_array_stride (tree descriptor, int dim)
1771 type = TREE_TYPE (descriptor);
1773 /* For descriptorless arrays use the array size. */
1774 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1775 if (tmp != NULL_TREE)
1778 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1783 /* Like gfc_conv_array_stride, but for the lower bound. */
1786 gfc_conv_array_lbound (tree descriptor, int dim)
1791 type = TREE_TYPE (descriptor);
1793 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1794 if (tmp != NULL_TREE)
1797 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1802 /* Like gfc_conv_array_stride, but for the upper bound. */
1805 gfc_conv_array_ubound (tree descriptor, int dim)
1810 type = TREE_TYPE (descriptor);
1812 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1813 if (tmp != NULL_TREE)
1816 /* This should only ever happen when passing an assumed shape array
1817 as an actual parameter. The value will never be used. */
1818 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1819 return gfc_index_zero_node;
1821 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1826 /* Generate code to perform an array index bound check. */
1829 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
1836 if (!flag_bounds_check)
1839 index = gfc_evaluate_now (index, &se->pre);
1841 /* Check lower bound. */
1842 tmp = gfc_conv_array_lbound (descriptor, n);
1843 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1845 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
1846 gfc_msg_fault, se->ss->expr->symtree->name, n+1);
1848 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
1849 gfc_msg_fault, n+1);
1850 gfc_trans_runtime_check (fault, msg, &se->pre, where);
1853 /* Check upper bound. */
1854 tmp = gfc_conv_array_ubound (descriptor, n);
1855 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1857 asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
1858 gfc_msg_fault, se->ss->expr->symtree->name, n+1);
1860 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
1861 gfc_msg_fault, n+1);
1862 gfc_trans_runtime_check (fault, msg, &se->pre, where);
1869 /* Return the offset for an index. Performs bound checking for elemental
1870 dimensions. Single element references are processed separately. */
1873 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1874 gfc_array_ref * ar, tree stride)
1880 /* Get the index into the array for this dimension. */
1883 gcc_assert (ar->type != AR_ELEMENT);
1884 switch (ar->dimen_type[dim])
1887 gcc_assert (i == -1);
1888 /* Elemental dimension. */
1889 gcc_assert (info->subscript[dim]
1890 && info->subscript[dim]->type == GFC_SS_SCALAR);
1891 /* We've already translated this value outside the loop. */
1892 index = info->subscript[dim]->data.scalar.expr;
1894 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
1895 || dim < ar->dimen - 1)
1896 index = gfc_trans_array_bound_check (se, info->descriptor,
1897 index, dim, &ar->where);
1901 gcc_assert (info && se->loop);
1902 gcc_assert (info->subscript[dim]
1903 && info->subscript[dim]->type == GFC_SS_VECTOR);
1904 desc = info->subscript[dim]->data.info.descriptor;
1906 /* Get a zero-based index into the vector. */
1907 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1908 se->loop->loopvar[i], se->loop->from[i]);
1910 /* Multiply the index by the stride. */
1911 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1912 index, gfc_conv_array_stride (desc, 0));
1914 /* Read the vector to get an index into info->descriptor. */
1915 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1916 index = gfc_build_array_ref (data, index);
1917 index = gfc_evaluate_now (index, &se->pre);
1919 /* Do any bounds checking on the final info->descriptor index. */
1920 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
1921 || dim < ar->dimen - 1)
1922 index = gfc_trans_array_bound_check (se, info->descriptor,
1923 index, dim, &ar->where);
1927 /* Scalarized dimension. */
1928 gcc_assert (info && se->loop);
1930 /* Multiply the loop variable by the stride and delta. */
1931 index = se->loop->loopvar[i];
1932 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1934 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1944 /* Temporary array or derived type component. */
1945 gcc_assert (se->loop);
1946 index = se->loop->loopvar[se->loop->order[i]];
1947 if (!integer_zerop (info->delta[i]))
1948 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1949 index, info->delta[i]);
1952 /* Multiply by the stride. */
1953 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1959 /* Build a scalarized reference to an array. */
1962 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1969 info = &se->ss->data.info;
1971 n = se->loop->order[0];
1975 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1977 /* Add the offset for this dimension to the stored offset for all other
1979 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1981 tmp = build_fold_indirect_ref (info->data);
1982 se->expr = gfc_build_array_ref (tmp, index);
1986 /* Translate access of temporary array. */
1989 gfc_conv_tmp_array_ref (gfc_se * se)
1991 se->string_length = se->ss->string_length;
1992 gfc_conv_scalarized_array_ref (se, NULL);
1996 /* Build an array reference. se->expr already holds the array descriptor.
1997 This should be either a variable, indirect variable reference or component
1998 reference. For arrays which do not have a descriptor, se->expr will be
2000 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2003 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2012 /* Handle scalarized references separately. */
2013 if (ar->type != AR_ELEMENT)
2015 gfc_conv_scalarized_array_ref (se, ar);
2016 gfc_advance_se_ss_chain (se);
2020 index = gfc_index_zero_node;
2022 /* Calculate the offsets from all the dimensions. */
2023 for (n = 0; n < ar->dimen; n++)
2025 /* Calculate the index for this dimension. */
2026 gfc_init_se (&indexse, se);
2027 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2028 gfc_add_block_to_block (&se->pre, &indexse.pre);
2030 if (flag_bounds_check &&
2031 ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2032 || n < ar->dimen - 1))
2034 /* Check array bounds. */
2038 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
2040 tmp = gfc_conv_array_lbound (se->expr, n);
2041 cond = fold_build2 (LT_EXPR, boolean_type_node,
2043 asprintf (&msg, "%s for array '%s', "
2044 "lower bound of dimension %d exceeded", gfc_msg_fault,
2046 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2049 tmp = gfc_conv_array_ubound (se->expr, n);
2050 cond = fold_build2 (GT_EXPR, boolean_type_node,
2052 asprintf (&msg, "%s for array '%s', "
2053 "upper bound of dimension %d exceeded", gfc_msg_fault,
2055 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2059 /* Multiply the index by the stride. */
2060 stride = gfc_conv_array_stride (se->expr, n);
2061 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2064 /* And add it to the total. */
2065 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2068 tmp = gfc_conv_array_offset (se->expr);
2069 if (!integer_zerop (tmp))
2070 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2072 /* Access the calculated element. */
2073 tmp = gfc_conv_array_data (se->expr);
2074 tmp = build_fold_indirect_ref (tmp);
2075 se->expr = gfc_build_array_ref (tmp, index);
2079 /* Generate the code to be executed immediately before entering a
2080 scalarization loop. */
2083 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2084 stmtblock_t * pblock)
2093 /* This code will be executed before entering the scalarization loop
2094 for this dimension. */
2095 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2097 if ((ss->useflags & flag) == 0)
2100 if (ss->type != GFC_SS_SECTION
2101 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2102 && ss->type != GFC_SS_COMPONENT)
2105 info = &ss->data.info;
2107 if (dim >= info->dimen)
2110 if (dim == info->dimen - 1)
2112 /* For the outermost loop calculate the offset due to any
2113 elemental dimensions. It will have been initialized with the
2114 base offset of the array. */
2117 for (i = 0; i < info->ref->u.ar.dimen; i++)
2119 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2122 gfc_init_se (&se, NULL);
2124 se.expr = info->descriptor;
2125 stride = gfc_conv_array_stride (info->descriptor, i);
2126 index = gfc_conv_array_index_offset (&se, info, i, -1,
2129 gfc_add_block_to_block (pblock, &se.pre);
2131 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2132 info->offset, index);
2133 info->offset = gfc_evaluate_now (info->offset, pblock);
2137 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2140 stride = gfc_conv_array_stride (info->descriptor, 0);
2142 /* Calculate the stride of the innermost loop. Hopefully this will
2143 allow the backend optimizers to do their stuff more effectively.
2145 info->stride0 = gfc_evaluate_now (stride, pblock);
2149 /* Add the offset for the previous loop dimension. */
2154 ar = &info->ref->u.ar;
2155 i = loop->order[dim + 1];
2163 gfc_init_se (&se, NULL);
2165 se.expr = info->descriptor;
2166 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2167 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2169 gfc_add_block_to_block (pblock, &se.pre);
2170 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2171 info->offset, index);
2172 info->offset = gfc_evaluate_now (info->offset, pblock);
2175 /* Remember this offset for the second loop. */
2176 if (dim == loop->temp_dim - 1)
2177 info->saved_offset = info->offset;
2182 /* Start a scalarized expression. Creates a scope and declares loop
2186 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2192 gcc_assert (!loop->array_parameter);
2194 for (dim = loop->dimen - 1; dim >= 0; dim--)
2196 n = loop->order[dim];
2198 gfc_start_block (&loop->code[n]);
2200 /* Create the loop variable. */
2201 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2203 if (dim < loop->temp_dim)
2207 /* Calculate values that will be constant within this loop. */
2208 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2210 gfc_start_block (pbody);
2214 /* Generates the actual loop code for a scalarization loop. */
2217 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2218 stmtblock_t * pbody)
2226 loopbody = gfc_finish_block (pbody);
2228 /* Initialize the loopvar. */
2229 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2231 exit_label = gfc_build_label_decl (NULL_TREE);
2233 /* Generate the loop body. */
2234 gfc_init_block (&block);
2236 /* The exit condition. */
2237 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2238 tmp = build1_v (GOTO_EXPR, exit_label);
2239 TREE_USED (exit_label) = 1;
2240 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2241 gfc_add_expr_to_block (&block, tmp);
2243 /* The main body. */
2244 gfc_add_expr_to_block (&block, loopbody);
2246 /* Increment the loopvar. */
2247 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2248 loop->loopvar[n], gfc_index_one_node);
2249 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2251 /* Build the loop. */
2252 tmp = gfc_finish_block (&block);
2253 tmp = build1_v (LOOP_EXPR, tmp);
2254 gfc_add_expr_to_block (&loop->code[n], tmp);
2256 /* Add the exit label. */
2257 tmp = build1_v (LABEL_EXPR, exit_label);
2258 gfc_add_expr_to_block (&loop->code[n], tmp);
2262 /* Finishes and generates the loops for a scalarized expression. */
2265 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2270 stmtblock_t *pblock;
2274 /* Generate the loops. */
2275 for (dim = 0; dim < loop->dimen; dim++)
2277 n = loop->order[dim];
2278 gfc_trans_scalarized_loop_end (loop, n, pblock);
2279 loop->loopvar[n] = NULL_TREE;
2280 pblock = &loop->code[n];
2283 tmp = gfc_finish_block (pblock);
2284 gfc_add_expr_to_block (&loop->pre, tmp);
2286 /* Clear all the used flags. */
2287 for (ss = loop->ss; ss; ss = ss->loop_chain)
2292 /* Finish the main body of a scalarized expression, and start the secondary
2296 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2300 stmtblock_t *pblock;
2304 /* We finish as many loops as are used by the temporary. */
2305 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2307 n = loop->order[dim];
2308 gfc_trans_scalarized_loop_end (loop, n, pblock);
2309 loop->loopvar[n] = NULL_TREE;
2310 pblock = &loop->code[n];
2313 /* We don't want to finish the outermost loop entirely. */
2314 n = loop->order[loop->temp_dim - 1];
2315 gfc_trans_scalarized_loop_end (loop, n, pblock);
2317 /* Restore the initial offsets. */
2318 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2320 if ((ss->useflags & 2) == 0)
2323 if (ss->type != GFC_SS_SECTION
2324 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2325 && ss->type != GFC_SS_COMPONENT)
2328 ss->data.info.offset = ss->data.info.saved_offset;
2331 /* Restart all the inner loops we just finished. */
2332 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2334 n = loop->order[dim];
2336 gfc_start_block (&loop->code[n]);
2338 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2340 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2343 /* Start a block for the secondary copying code. */
2344 gfc_start_block (body);
2348 /* Calculate the upper bound of an array section. */
2351 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2360 gcc_assert (ss->type == GFC_SS_SECTION);
2362 info = &ss->data.info;
2365 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2366 /* We'll calculate the upper bound once we have access to the
2367 vector's descriptor. */
2370 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2371 desc = info->descriptor;
2372 end = info->ref->u.ar.end[dim];
2376 /* The upper bound was specified. */
2377 gfc_init_se (&se, NULL);
2378 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2379 gfc_add_block_to_block (pblock, &se.pre);
2384 /* No upper bound was specified, so use the bound of the array. */
2385 bound = gfc_conv_array_ubound (desc, dim);
2392 /* Calculate the lower bound of an array section. */
2395 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2404 gcc_assert (ss->type == GFC_SS_SECTION);
2406 info = &ss->data.info;
2409 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2411 /* We use a zero-based index to access the vector. */
2412 info->start[n] = gfc_index_zero_node;
2413 info->stride[n] = gfc_index_one_node;
2417 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2418 desc = info->descriptor;
2419 start = info->ref->u.ar.start[dim];
2420 stride = info->ref->u.ar.stride[dim];
2422 /* Calculate the start of the range. For vector subscripts this will
2423 be the range of the vector. */
2426 /* Specified section start. */
2427 gfc_init_se (&se, NULL);
2428 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2429 gfc_add_block_to_block (&loop->pre, &se.pre);
2430 info->start[n] = se.expr;
2434 /* No lower bound specified so use the bound of the array. */
2435 info->start[n] = gfc_conv_array_lbound (desc, dim);
2437 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2439 /* Calculate the stride. */
2441 info->stride[n] = gfc_index_one_node;
2444 gfc_init_se (&se, NULL);
2445 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2446 gfc_add_block_to_block (&loop->pre, &se.pre);
2447 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2452 /* Calculates the range start and stride for a SS chain. Also gets the
2453 descriptor and data pointer. The range of vector subscripts is the size
2454 of the vector. Array bounds are also checked. */
2457 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2465 /* Determine the rank of the loop. */
2467 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2471 case GFC_SS_SECTION:
2472 case GFC_SS_CONSTRUCTOR:
2473 case GFC_SS_FUNCTION:
2474 case GFC_SS_COMPONENT:
2475 loop->dimen = ss->data.info.dimen;
2478 /* As usual, lbound and ubound are exceptions!. */
2479 case GFC_SS_INTRINSIC:
2480 switch (ss->expr->value.function.isym->generic_id)
2482 case GFC_ISYM_LBOUND:
2483 case GFC_ISYM_UBOUND:
2484 loop->dimen = ss->data.info.dimen;
2495 if (loop->dimen == 0)
2496 gfc_todo_error ("Unable to determine rank of expression");
2499 /* Loop over all the SS in the chain. */
2500 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2502 if (ss->expr && ss->expr->shape && !ss->shape)
2503 ss->shape = ss->expr->shape;
2507 case GFC_SS_SECTION:
2508 /* Get the descriptor for the array. */
2509 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2511 for (n = 0; n < ss->data.info.dimen; n++)
2512 gfc_conv_section_startstride (loop, ss, n);
2515 case GFC_SS_INTRINSIC:
2516 switch (ss->expr->value.function.isym->generic_id)
2518 /* Fall through to supply start and stride. */
2519 case GFC_ISYM_LBOUND:
2520 case GFC_ISYM_UBOUND:
2526 case GFC_SS_CONSTRUCTOR:
2527 case GFC_SS_FUNCTION:
2528 for (n = 0; n < ss->data.info.dimen; n++)
2530 ss->data.info.start[n] = gfc_index_zero_node;
2531 ss->data.info.stride[n] = gfc_index_one_node;
2540 /* The rest is just runtime bound checking. */
2541 if (flag_bounds_check)
2544 tree lbound, ubound;
2546 tree size[GFC_MAX_DIMENSIONS];
2547 tree stride_pos, stride_neg, non_zerosized, tmp2;
2552 gfc_start_block (&block);
2554 for (n = 0; n < loop->dimen; n++)
2555 size[n] = NULL_TREE;
2557 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2559 if (ss->type != GFC_SS_SECTION)
2562 /* TODO: range checking for mapped dimensions. */
2563 info = &ss->data.info;
2565 /* This code only checks ranges. Elemental and vector
2566 dimensions are checked later. */
2567 for (n = 0; n < loop->dimen; n++)
2570 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2572 if (n == info->ref->u.ar.dimen - 1
2573 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2574 || info->ref->u.ar.as->cp_was_assumed))
2577 desc = ss->data.info.descriptor;
2579 /* This is the run-time equivalent of resolve.c's
2580 check_dimension(). The logical is more readable there
2581 than it is here, with all the trees. */
2582 lbound = gfc_conv_array_lbound (desc, dim);
2583 ubound = gfc_conv_array_ubound (desc, dim);
2584 end = gfc_conv_section_upper_bound (ss, n, &block);
2586 /* Zero stride is not allowed. */
2587 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2588 gfc_index_zero_node);
2589 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2590 "of array '%s'", info->dim[n]+1,
2591 ss->expr->symtree->name);
2592 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2595 /* non_zerosized is true when the selected range is not
2597 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2598 info->stride[n], gfc_index_zero_node);
2599 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2601 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2604 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2605 info->stride[n], gfc_index_zero_node);
2606 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2608 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2610 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2611 stride_pos, stride_neg);
2613 /* Check the start of the range against the lower and upper
2614 bounds of the array, if the range is not empty. */
2615 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2617 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2618 non_zerosized, tmp);
2619 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2620 " exceeded", gfc_msg_fault, info->dim[n]+1,
2621 ss->expr->symtree->name);
2622 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2625 tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n],
2627 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2628 non_zerosized, tmp);
2629 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2630 " exceeded", gfc_msg_fault, info->dim[n]+1,
2631 ss->expr->symtree->name);
2632 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2635 /* Compute the last element of the range, which is not
2636 necessarily "end" (think 0:5:3, which doesn't contain 5)
2637 and check it against both lower and upper bounds. */
2638 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2640 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2642 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2645 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2646 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2647 non_zerosized, tmp);
2648 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2649 " exceeded", gfc_msg_fault, info->dim[n]+1,
2650 ss->expr->symtree->name);
2651 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2654 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2655 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2656 non_zerosized, tmp);
2657 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2658 " exceeded", gfc_msg_fault, info->dim[n]+1,
2659 ss->expr->symtree->name);
2660 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2663 /* Check the section sizes match. */
2664 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2666 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2668 /* We remember the size of the first section, and check all the
2669 others against this. */
2673 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2674 asprintf (&msg, "%s, size mismatch for dimension %d "
2675 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2676 ss->expr->symtree->name);
2677 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2681 size[n] = gfc_evaluate_now (tmp, &block);
2685 tmp = gfc_finish_block (&block);
2686 gfc_add_expr_to_block (&loop->pre, tmp);
2691 /* Return true if the two SS could be aliased, i.e. both point to the same data
2693 /* TODO: resolve aliases based on frontend expressions. */
2696 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2703 lsym = lss->expr->symtree->n.sym;
2704 rsym = rss->expr->symtree->n.sym;
2705 if (gfc_symbols_could_alias (lsym, rsym))
2708 if (rsym->ts.type != BT_DERIVED
2709 && lsym->ts.type != BT_DERIVED)
2712 /* For derived types we must check all the component types. We can ignore
2713 array references as these will have the same base type as the previous
2715 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2717 if (lref->type != REF_COMPONENT)
2720 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2723 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2726 if (rref->type != REF_COMPONENT)
2729 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2734 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2736 if (rref->type != REF_COMPONENT)
2739 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2747 /* Resolve array data dependencies. Creates a temporary if required. */
2748 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2752 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2762 loop->temp_ss = NULL;
2763 aref = dest->data.info.ref;
2766 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2768 if (ss->type != GFC_SS_SECTION)
2771 if (gfc_could_be_alias (dest, ss)
2772 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2778 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2780 lref = dest->expr->ref;
2781 rref = ss->expr->ref;
2783 nDepend = gfc_dep_resolver (lref, rref);
2785 /* TODO : loop shifting. */
2788 /* Mark the dimensions for LOOP SHIFTING */
2789 for (n = 0; n < loop->dimen; n++)
2791 int dim = dest->data.info.dim[n];
2793 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2795 else if (! gfc_is_same_range (&lref->u.ar,
2796 &rref->u.ar, dim, 0))
2800 /* Put all the dimensions with dependencies in the
2803 for (n = 0; n < loop->dimen; n++)
2805 gcc_assert (loop->order[n] == n);
2807 loop->order[dim++] = n;
2810 for (n = 0; n < loop->dimen; n++)
2813 loop->order[dim++] = n;
2816 gcc_assert (dim == loop->dimen);
2825 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2826 if (GFC_ARRAY_TYPE_P (base_type)
2827 || GFC_DESCRIPTOR_TYPE_P (base_type))
2828 base_type = gfc_get_element_type (base_type);
2829 loop->temp_ss = gfc_get_ss ();
2830 loop->temp_ss->type = GFC_SS_TEMP;
2831 loop->temp_ss->data.temp.type = base_type;
2832 loop->temp_ss->string_length = dest->string_length;
2833 loop->temp_ss->data.temp.dimen = loop->dimen;
2834 loop->temp_ss->next = gfc_ss_terminator;
2835 gfc_add_ss_to_loop (loop, loop->temp_ss);
2838 loop->temp_ss = NULL;
2842 /* Initialize the scalarization loop. Creates the loop variables. Determines
2843 the range of the loop variables. Creates a temporary if required.
2844 Calculates how to transform from loop variables to array indices for each
2845 expression. Also generates code for scalar expressions which have been
2846 moved outside the loop. */
2849 gfc_conv_loop_setup (gfc_loopinfo * loop)
2854 gfc_ss_info *specinfo;
2858 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2859 bool dynamic[GFC_MAX_DIMENSIONS];
2865 for (n = 0; n < loop->dimen; n++)
2869 /* We use one SS term, and use that to determine the bounds of the
2870 loop for this dimension. We try to pick the simplest term. */
2871 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2875 /* The frontend has worked out the size for us. */
2880 if (ss->type == GFC_SS_CONSTRUCTOR)
2882 /* An unknown size constructor will always be rank one.
2883 Higher rank constructors will either have known shape,
2884 or still be wrapped in a call to reshape. */
2885 gcc_assert (loop->dimen == 1);
2887 /* Always prefer to use the constructor bounds if the size
2888 can be determined at compile time. Prefer not to otherwise,
2889 since the general case involves realloc, and it's better to
2890 avoid that overhead if possible. */
2891 c = ss->expr->value.constructor;
2892 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2893 if (!dynamic[n] || !loopspec[n])
2898 /* TODO: Pick the best bound if we have a choice between a
2899 function and something else. */
2900 if (ss->type == GFC_SS_FUNCTION)
2906 if (ss->type != GFC_SS_SECTION)
2910 specinfo = &loopspec[n]->data.info;
2913 info = &ss->data.info;
2917 /* Criteria for choosing a loop specifier (most important first):
2918 doesn't need realloc
2924 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2926 else if (integer_onep (info->stride[n])
2927 && !integer_onep (specinfo->stride[n]))
2929 else if (INTEGER_CST_P (info->stride[n])
2930 && !INTEGER_CST_P (specinfo->stride[n]))
2932 else if (INTEGER_CST_P (info->start[n])
2933 && !INTEGER_CST_P (specinfo->start[n]))
2935 /* We don't work out the upper bound.
2936 else if (INTEGER_CST_P (info->finish[n])
2937 && ! INTEGER_CST_P (specinfo->finish[n]))
2938 loopspec[n] = ss; */
2942 gfc_todo_error ("Unable to find scalarization loop specifier");
2944 info = &loopspec[n]->data.info;
2946 /* Set the extents of this range. */
2947 cshape = loopspec[n]->shape;
2948 if (cshape && INTEGER_CST_P (info->start[n])
2949 && INTEGER_CST_P (info->stride[n]))
2951 loop->from[n] = info->start[n];
2952 mpz_set (i, cshape[n]);
2953 mpz_sub_ui (i, i, 1);
2954 /* To = from + (size - 1) * stride. */
2955 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2956 if (!integer_onep (info->stride[n]))
2957 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2958 tmp, info->stride[n]);
2959 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2960 loop->from[n], tmp);
2964 loop->from[n] = info->start[n];
2965 switch (loopspec[n]->type)
2967 case GFC_SS_CONSTRUCTOR:
2968 /* The upper bound is calculated when we expand the
2970 gcc_assert (loop->to[n] == NULL_TREE);
2973 case GFC_SS_SECTION:
2974 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2978 case GFC_SS_FUNCTION:
2979 /* The loop bound will be set when we generate the call. */
2980 gcc_assert (loop->to[n] == NULL_TREE);
2988 /* Transform everything so we have a simple incrementing variable. */
2989 if (integer_onep (info->stride[n]))
2990 info->delta[n] = gfc_index_zero_node;
2993 /* Set the delta for this section. */
2994 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2995 /* Number of iterations is (end - start + step) / step.
2996 with start = 0, this simplifies to
2998 for (i = 0; i<=last; i++){...}; */
2999 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3000 loop->to[n], loop->from[n]);
3001 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3002 tmp, info->stride[n]);
3003 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3004 /* Make the loop variable start at 0. */
3005 loop->from[n] = gfc_index_zero_node;
3009 /* Add all the scalar code that can be taken out of the loops.
3010 This may include calculating the loop bounds, so do it before
3011 allocating the temporary. */
3012 gfc_add_loop_ss_code (loop, loop->ss, false);
3014 /* If we want a temporary then create it. */
3015 if (loop->temp_ss != NULL)
3017 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3018 tmp = loop->temp_ss->data.temp.type;
3019 len = loop->temp_ss->string_length;
3020 n = loop->temp_ss->data.temp.dimen;
3021 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3022 loop->temp_ss->type = GFC_SS_SECTION;
3023 loop->temp_ss->data.info.dimen = n;
3024 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3025 &loop->temp_ss->data.info, tmp, false, true,
3029 for (n = 0; n < loop->temp_dim; n++)
3030 loopspec[loop->order[n]] = NULL;
3034 /* For array parameters we don't have loop variables, so don't calculate the
3036 if (loop->array_parameter)
3039 /* Calculate the translation from loop variables to array indices. */
3040 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3042 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3045 info = &ss->data.info;
3047 for (n = 0; n < info->dimen; n++)
3051 /* If we are specifying the range the delta is already set. */
3052 if (loopspec[n] != ss)
3054 /* Calculate the offset relative to the loop variable.
3055 First multiply by the stride. */
3056 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3057 loop->from[n], info->stride[n]);
3059 /* Then subtract this from our starting value. */
3060 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3061 info->start[n], tmp);
3063 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3070 /* Fills in an array descriptor, and returns the size of the array. The size
3071 will be a simple_val, ie a variable or a constant. Also calculates the
3072 offset of the base. Returns the size of the array.
3076 for (n = 0; n < rank; n++)
3078 a.lbound[n] = specified_lower_bound;
3079 offset = offset + a.lbond[n] * stride;
3081 a.ubound[n] = specified_upper_bound;
3082 a.stride[n] = stride;
3083 size = ubound + size; //size = ubound + 1 - lbound
3084 stride = stride * size;
3091 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3092 gfc_expr ** lower, gfc_expr ** upper,
3093 stmtblock_t * pblock)
3105 stmtblock_t thenblock;
3106 stmtblock_t elseblock;
3111 type = TREE_TYPE (descriptor);
3113 stride = gfc_index_one_node;
3114 offset = gfc_index_zero_node;
3116 /* Set the dtype. */
3117 tmp = gfc_conv_descriptor_dtype (descriptor);
3118 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3120 or_expr = NULL_TREE;
3122 for (n = 0; n < rank; n++)
3124 /* We have 3 possibilities for determining the size of the array:
3125 lower == NULL => lbound = 1, ubound = upper[n]
3126 upper[n] = NULL => lbound = 1, ubound = lower[n]
3127 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3130 /* Set lower bound. */
3131 gfc_init_se (&se, NULL);
3133 se.expr = gfc_index_one_node;
3136 gcc_assert (lower[n]);
3139 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3140 gfc_add_block_to_block (pblock, &se.pre);
3144 se.expr = gfc_index_one_node;
3148 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3149 gfc_add_modify_expr (pblock, tmp, se.expr);
3151 /* Work out the offset for this component. */
3152 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3153 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3155 /* Start the calculation for the size of this dimension. */
3156 size = build2 (MINUS_EXPR, gfc_array_index_type,
3157 gfc_index_one_node, se.expr);
3159 /* Set upper bound. */
3160 gfc_init_se (&se, NULL);
3161 gcc_assert (ubound);
3162 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3163 gfc_add_block_to_block (pblock, &se.pre);
3165 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3166 gfc_add_modify_expr (pblock, tmp, se.expr);
3168 /* Store the stride. */
3169 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3170 gfc_add_modify_expr (pblock, tmp, stride);
3172 /* Calculate the size of this dimension. */
3173 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3175 /* Check wether the size for this dimension is negative. */
3176 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3177 gfc_index_zero_node);
3181 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3183 /* Multiply the stride by the number of elements in this dimension. */
3184 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3185 stride = gfc_evaluate_now (stride, pblock);
3188 /* The stride is the number of elements in the array, so multiply by the
3189 size of an element to get the total size. */
3190 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3191 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3193 if (poffset != NULL)
3195 offset = gfc_evaluate_now (offset, pblock);
3199 var = gfc_create_var (TREE_TYPE (size), "size");
3200 gfc_start_block (&thenblock);
3201 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3202 thencase = gfc_finish_block (&thenblock);
3204 gfc_start_block (&elseblock);
3205 gfc_add_modify_expr (&elseblock, var, size);
3206 elsecase = gfc_finish_block (&elseblock);
3208 tmp = gfc_evaluate_now (or_expr, pblock);
3209 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3210 gfc_add_expr_to_block (pblock, tmp);
3216 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3217 the work for an ALLOCATE statement. */
3221 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3231 int allocatable_array;
3232 int must_be_pointer;
3236 /* In Fortran 95, components can only contain pointers, so that,
3237 in ALLOCATE (foo%bar(2)), bar must be a pointer component.
3238 We test this by checking for ref->next.
3239 An implementation of TR 15581 would need to change this. */
3242 must_be_pointer = ref->next != NULL;
3244 must_be_pointer = 0;
3246 /* Find the last reference in the chain. */
3247 while (ref && ref->next != NULL)
3249 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3253 if (ref == NULL || ref->type != REF_ARRAY)
3256 /* Figure out the size of the array. */
3257 switch (ref->u.ar.type)
3261 upper = ref->u.ar.start;
3265 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3267 lower = ref->u.ar.as->lower;
3268 upper = ref->u.ar.as->upper;
3272 lower = ref->u.ar.start;
3273 upper = ref->u.ar.end;
3281 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3282 lower, upper, &se->pre);
3284 /* Allocate memory to store the data. */
3285 tmp = gfc_conv_descriptor_data_addr (se->expr);
3286 pointer = gfc_evaluate_now (tmp, &se->pre);
3288 if (must_be_pointer)
3289 allocatable_array = 0;
3291 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3293 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3295 if (allocatable_array)
3296 allocate = gfor_fndecl_allocate_array;
3298 allocate = gfor_fndecl_allocate;
3300 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3302 if (allocatable_array)
3303 allocate = gfor_fndecl_allocate64_array;
3305 allocate = gfor_fndecl_allocate64;
3310 tmp = gfc_chainon_list (NULL_TREE, pointer);
3311 tmp = gfc_chainon_list (tmp, size);
3312 tmp = gfc_chainon_list (tmp, pstat);
3313 tmp = build_function_call_expr (allocate, tmp);
3314 gfc_add_expr_to_block (&se->pre, tmp);
3316 tmp = gfc_conv_descriptor_offset (se->expr);
3317 gfc_add_modify_expr (&se->pre, tmp, offset);
3323 /* Deallocate an array variable. Also used when an allocated variable goes
3328 gfc_array_deallocate (tree descriptor, tree pstat)
3334 gfc_start_block (&block);
3335 /* Get a pointer to the data. */
3336 tmp = gfc_conv_descriptor_data_addr (descriptor);
3337 var = gfc_evaluate_now (tmp, &block);
3339 /* Parameter is the address of the data component. */
3340 tmp = gfc_chainon_list (NULL_TREE, var);
3341 tmp = gfc_chainon_list (tmp, pstat);
3342 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3343 gfc_add_expr_to_block (&block, tmp);
3345 return gfc_finish_block (&block);
3349 /* Create an array constructor from an initialization expression.
3350 We assume the frontend already did any expansions and conversions. */
3353 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3360 unsigned HOST_WIDE_INT lo;
3362 VEC(constructor_elt,gc) *v = NULL;
3364 switch (expr->expr_type)
3367 case EXPR_STRUCTURE:
3368 /* A single scalar or derived type value. Create an array with all
3369 elements equal to that value. */
3370 gfc_init_se (&se, NULL);
3372 if (expr->expr_type == EXPR_CONSTANT)
3373 gfc_conv_constant (&se, expr);
3375 gfc_conv_structure (&se, expr, 1);
3377 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3378 gcc_assert (tmp && INTEGER_CST_P (tmp));
3379 hi = TREE_INT_CST_HIGH (tmp);
3380 lo = TREE_INT_CST_LOW (tmp);
3384 /* This will probably eat buckets of memory for large arrays. */
3385 while (hi != 0 || lo != 0)
3387 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3395 /* Create a vector of all the elements. */
3396 for (c = expr->value.constructor; c; c = c->next)
3400 /* Problems occur when we get something like
3401 integer :: a(lots) = (/(i, i=1,lots)/) */
3402 /* TODO: Unexpanded array initializers. */
3404 ("Possible frontend bug: array constructor not expanded");
3406 if (mpz_cmp_si (c->n.offset, 0) != 0)
3407 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3411 if (mpz_cmp_si (c->repeat, 0) != 0)
3415 mpz_set (maxval, c->repeat);
3416 mpz_add (maxval, c->n.offset, maxval);
3417 mpz_sub_ui (maxval, maxval, 1);
3418 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3419 if (mpz_cmp_si (c->n.offset, 0) != 0)
3421 mpz_add_ui (maxval, c->n.offset, 1);
3422 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3425 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3427 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3433 gfc_init_se (&se, NULL);
3434 switch (c->expr->expr_type)
3437 gfc_conv_constant (&se, c->expr);
3438 if (range == NULL_TREE)
3439 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3442 if (index != NULL_TREE)
3443 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3444 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3448 case EXPR_STRUCTURE:
3449 gfc_conv_structure (&se, c->expr, 1);
3450 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3463 /* Create a constructor from the list of elements. */
3464 tmp = build_constructor (type, v);
3465 TREE_CONSTANT (tmp) = 1;
3466 TREE_INVARIANT (tmp) = 1;
3471 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3472 returns the size (in elements) of the array. */
3475 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3476 stmtblock_t * pblock)
3491 size = gfc_index_one_node;
3492 offset = gfc_index_zero_node;
3493 for (dim = 0; dim < as->rank; dim++)
3495 /* Evaluate non-constant array bound expressions. */
3496 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3497 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3499 gfc_init_se (&se, NULL);
3500 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3501 gfc_add_block_to_block (pblock, &se.pre);
3502 gfc_add_modify_expr (pblock, lbound, se.expr);
3504 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3505 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3507 gfc_init_se (&se, NULL);
3508 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3509 gfc_add_block_to_block (pblock, &se.pre);
3510 gfc_add_modify_expr (pblock, ubound, se.expr);
3512 /* The offset of this dimension. offset = offset - lbound * stride. */
3513 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3514 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3516 /* The size of this dimension, and the stride of the next. */
3517 if (dim + 1 < as->rank)
3518 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3520 stride = GFC_TYPE_ARRAY_SIZE (type);
3522 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3524 /* Calculate stride = size * (ubound + 1 - lbound). */
3525 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3526 gfc_index_one_node, lbound);
3527 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3528 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3530 gfc_add_modify_expr (pblock, stride, tmp);
3532 stride = gfc_evaluate_now (tmp, pblock);
3538 gfc_trans_vla_type_sizes (sym, pblock);
3545 /* Generate code to initialize/allocate an array variable. */
3548 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3558 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3560 /* Do nothing for USEd variables. */
3561 if (sym->attr.use_assoc)
3564 type = TREE_TYPE (decl);
3565 gcc_assert (GFC_ARRAY_TYPE_P (type));
3566 onstack = TREE_CODE (type) != POINTER_TYPE;
3568 gfc_start_block (&block);
3570 /* Evaluate character string length. */
3571 if (sym->ts.type == BT_CHARACTER
3572 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3574 gfc_trans_init_string_length (sym->ts.cl, &block);
3576 gfc_trans_vla_type_sizes (sym, &block);
3578 /* Emit a DECL_EXPR for this variable, which will cause the
3579 gimplifier to allocate storage, and all that good stuff. */
3580 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3581 gfc_add_expr_to_block (&block, tmp);
3586 gfc_add_expr_to_block (&block, fnbody);
3587 return gfc_finish_block (&block);
3590 type = TREE_TYPE (type);
3592 gcc_assert (!sym->attr.use_assoc);
3593 gcc_assert (!TREE_STATIC (decl));
3594 gcc_assert (!sym->module);
3596 if (sym->ts.type == BT_CHARACTER
3597 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3598 gfc_trans_init_string_length (sym->ts.cl, &block);
3600 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3602 /* Don't actually allocate space for Cray Pointees. */
3603 if (sym->attr.cray_pointee)
3605 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3606 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3607 gfc_add_expr_to_block (&block, fnbody);
3608 return gfc_finish_block (&block);
3611 /* The size is the number of elements in the array, so multiply by the
3612 size of an element to get the total size. */
3613 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3614 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3616 /* Allocate memory to hold the data. */
3617 tmp = gfc_chainon_list (NULL_TREE, size);
3619 if (gfc_index_integer_kind == 4)
3620 fndecl = gfor_fndecl_internal_malloc;
3621 else if (gfc_index_integer_kind == 8)
3622 fndecl = gfor_fndecl_internal_malloc64;
3625 tmp = build_function_call_expr (fndecl, tmp);
3626 tmp = fold (convert (TREE_TYPE (decl), tmp));
3627 gfc_add_modify_expr (&block, decl, tmp);
3629 /* Set offset of the array. */
3630 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3631 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3634 /* Automatic arrays should not have initializers. */
3635 gcc_assert (!sym->value);
3637 gfc_add_expr_to_block (&block, fnbody);
3639 /* Free the temporary. */
3640 tmp = convert (pvoid_type_node, decl);
3641 tmp = gfc_chainon_list (NULL_TREE, tmp);
3642 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3643 gfc_add_expr_to_block (&block, tmp);
3645 return gfc_finish_block (&block);
3649 /* Generate entry and exit code for g77 calling convention arrays. */
3652 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3661 gfc_get_backend_locus (&loc);
3662 gfc_set_backend_locus (&sym->declared_at);
3664 /* Descriptor type. */
3665 parm = sym->backend_decl;
3666 type = TREE_TYPE (parm);
3667 gcc_assert (GFC_ARRAY_TYPE_P (type));
3669 gfc_start_block (&block);
3671 if (sym->ts.type == BT_CHARACTER
3672 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3673 gfc_trans_init_string_length (sym->ts.cl, &block);
3675 /* Evaluate the bounds of the array. */
3676 gfc_trans_array_bounds (type, sym, &offset, &block);
3678 /* Set the offset. */
3679 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3680 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3682 /* Set the pointer itself if we aren't using the parameter directly. */
3683 if (TREE_CODE (parm) != PARM_DECL)
3685 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3686 gfc_add_modify_expr (&block, parm, tmp);
3688 tmp = gfc_finish_block (&block);
3690 gfc_set_backend_locus (&loc);
3692 gfc_start_block (&block);
3693 /* Add the initialization code to the start of the function. */
3694 gfc_add_expr_to_block (&block, tmp);
3695 gfc_add_expr_to_block (&block, body);
3697 return gfc_finish_block (&block);
3701 /* Modify the descriptor of an array parameter so that it has the
3702 correct lower bound. Also move the upper bound accordingly.
3703 If the array is not packed, it will be copied into a temporary.
3704 For each dimension we set the new lower and upper bounds. Then we copy the
3705 stride and calculate the offset for this dimension. We also work out
3706 what the stride of a packed array would be, and see it the two match.
3707 If the array need repacking, we set the stride to the values we just
3708 calculated, recalculate the offset and copy the array data.
3709 Code is also added to copy the data back at the end of the function.
3713 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3720 stmtblock_t cleanup;
3728 tree stride, stride2;
3738 /* Do nothing for pointer and allocatable arrays. */
3739 if (sym->attr.pointer || sym->attr.allocatable)
3742 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3743 return gfc_trans_g77_array (sym, body);
3745 gfc_get_backend_locus (&loc);
3746 gfc_set_backend_locus (&sym->declared_at);
3748 /* Descriptor type. */
3749 type = TREE_TYPE (tmpdesc);
3750 gcc_assert (GFC_ARRAY_TYPE_P (type));
3751 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3752 dumdesc = build_fold_indirect_ref (dumdesc);
3753 gfc_start_block (&block);
3755 if (sym->ts.type == BT_CHARACTER
3756 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3757 gfc_trans_init_string_length (sym->ts.cl, &block);
3759 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3761 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3762 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3764 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3766 /* For non-constant shape arrays we only check if the first dimension
3767 is contiguous. Repacking higher dimensions wouldn't gain us
3768 anything as we still don't know the array stride. */
3769 partial = gfc_create_var (boolean_type_node, "partial");
3770 TREE_USED (partial) = 1;
3771 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3772 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
3773 gfc_add_modify_expr (&block, partial, tmp);
3777 partial = NULL_TREE;
3780 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3781 here, however I think it does the right thing. */
3784 /* Set the first stride. */
3785 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3786 stride = gfc_evaluate_now (stride, &block);
3788 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
3789 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3790 gfc_index_one_node, stride);
3791 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3792 gfc_add_modify_expr (&block, stride, tmp);
3794 /* Allow the user to disable array repacking. */
3795 stmt_unpacked = NULL_TREE;
3799 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3800 /* A library call to repack the array if necessary. */
3801 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3802 tmp = gfc_chainon_list (NULL_TREE, tmp);
3803 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3805 stride = gfc_index_one_node;
3808 /* This is for the case where the array data is used directly without
3809 calling the repack function. */
3810 if (no_repack || partial != NULL_TREE)
3811 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3813 stmt_packed = NULL_TREE;
3815 /* Assign the data pointer. */
3816 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3818 /* Don't repack unknown shape arrays when the first stride is 1. */
3819 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3820 stmt_packed, stmt_unpacked);
3823 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3824 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3826 offset = gfc_index_zero_node;
3827 size = gfc_index_one_node;
3829 /* Evaluate the bounds of the array. */
3830 for (n = 0; n < sym->as->rank; n++)
3832 if (checkparm || !sym->as->upper[n])
3834 /* Get the bounds of the actual parameter. */
3835 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3836 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3840 dubound = NULL_TREE;
3841 dlbound = NULL_TREE;
3844 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3845 if (!INTEGER_CST_P (lbound))
3847 gfc_init_se (&se, NULL);
3848 gfc_conv_expr_type (&se, sym->as->lower[n],
3849 gfc_array_index_type);
3850 gfc_add_block_to_block (&block, &se.pre);
3851 gfc_add_modify_expr (&block, lbound, se.expr);
3854 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3855 /* Set the desired upper bound. */
3856 if (sym->as->upper[n])
3858 /* We know what we want the upper bound to be. */
3859 if (!INTEGER_CST_P (ubound))
3861 gfc_init_se (&se, NULL);
3862 gfc_conv_expr_type (&se, sym->as->upper[n],
3863 gfc_array_index_type);
3864 gfc_add_block_to_block (&block, &se.pre);
3865 gfc_add_modify_expr (&block, ubound, se.expr);
3868 /* Check the sizes match. */
3871 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3874 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3876 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
3878 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
3879 asprintf (&msg, "%s for dimension %d of array '%s'",
3880 gfc_msg_bounds, n+1, sym->name);
3881 gfc_trans_runtime_check (tmp, msg, &block, NULL);
3887 /* For assumed shape arrays move the upper bound by the same amount
3888 as the lower bound. */
3889 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3890 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3891 gfc_add_modify_expr (&block, ubound, tmp);
3893 /* The offset of this dimension. offset = offset - lbound * stride. */
3894 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3895 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3897 /* The size of this dimension, and the stride of the next. */
3898 if (n + 1 < sym->as->rank)
3900 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3902 if (no_repack || partial != NULL_TREE)
3905 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3908 /* Figure out the stride if not a known constant. */
3909 if (!INTEGER_CST_P (stride))
3912 stmt_packed = NULL_TREE;
3915 /* Calculate stride = size * (ubound + 1 - lbound). */
3916 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3917 gfc_index_one_node, lbound);
3918 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3920 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3925 /* Assign the stride. */
3926 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3927 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3928 stmt_unpacked, stmt_packed);
3930 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3931 gfc_add_modify_expr (&block, stride, tmp);
3936 stride = GFC_TYPE_ARRAY_SIZE (type);
3938 if (stride && !INTEGER_CST_P (stride))
3940 /* Calculate size = stride * (ubound + 1 - lbound). */
3941 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3942 gfc_index_one_node, lbound);
3943 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3945 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3946 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
3947 gfc_add_modify_expr (&block, stride, tmp);
3952 /* Set the offset. */
3953 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3954 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3956 gfc_trans_vla_type_sizes (sym, &block);
3958 stmt = gfc_finish_block (&block);
3960 gfc_start_block (&block);
3962 /* Only do the entry/initialization code if the arg is present. */
3963 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3964 optional_arg = (sym->attr.optional
3965 || (sym->ns->proc_name->attr.entry_master
3966 && sym->attr.dummy));
3969 tmp = gfc_conv_expr_present (sym);
3970 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3972 gfc_add_expr_to_block (&block, stmt);
3974 /* Add the main function body. */
3975 gfc_add_expr_to_block (&block, body);
3980 gfc_start_block (&cleanup);
3982 if (sym->attr.intent != INTENT_IN)
3984 /* Copy the data back. */
3985 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3986 tmp = gfc_chainon_list (tmp, tmpdesc);
3987 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3988 gfc_add_expr_to_block (&cleanup, tmp);
3991 /* Free the temporary. */
3992 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3993 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3994 gfc_add_expr_to_block (&cleanup, tmp);
3996 stmt = gfc_finish_block (&cleanup);
3998 /* Only do the cleanup if the array was repacked. */
3999 tmp = build_fold_indirect_ref (dumdesc);
4000 tmp = gfc_conv_descriptor_data_get (tmp);
4001 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4002 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4006 tmp = gfc_conv_expr_present (sym);
4007 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4009 gfc_add_expr_to_block (&block, stmt);
4011 /* We don't need to free any memory allocated by internal_pack as it will
4012 be freed at the end of the function by pop_context. */
4013 return gfc_finish_block (&block);
4017 /* Convert an array for passing as an actual argument. Expressions and
4018 vector subscripts are evaluated and stored in a temporary, which is then
4019 passed. For whole arrays the descriptor is passed. For array sections
4020 a modified copy of the descriptor is passed, but using the original data.
4022 This function is also used for array pointer assignments, and there
4025 - want_pointer && !se->direct_byref
4026 EXPR is an actual argument. On exit, se->expr contains a
4027 pointer to the array descriptor.
4029 - !want_pointer && !se->direct_byref
4030 EXPR is an actual argument to an intrinsic function or the
4031 left-hand side of a pointer assignment. On exit, se->expr
4032 contains the descriptor for EXPR.
4034 - !want_pointer && se->direct_byref
4035 EXPR is the right-hand side of a pointer assignment and
4036 se->expr is the descriptor for the previously-evaluated
4037 left-hand side. The function creates an assignment from
4038 EXPR to se->expr. */
4041 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4056 gcc_assert (ss != gfc_ss_terminator);
4058 /* TODO: Pass constant array constructors without a temporary. */
4059 /* Special case things we know we can pass easily. */
4060 switch (expr->expr_type)
4063 /* If we have a linear array section, we can pass it directly.
4064 Otherwise we need to copy it into a temporary. */
4066 /* Find the SS for the array section. */
4068 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4069 secss = secss->next;
4071 gcc_assert (secss != gfc_ss_terminator);
4072 info = &secss->data.info;
4074 /* Get the descriptor for the array. */
4075 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4076 desc = info->descriptor;
4078 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4081 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4083 /* Create a new descriptor if the array doesn't have one. */
4086 else if (info->ref->u.ar.type == AR_FULL)
4088 else if (se->direct_byref)
4093 gcc_assert (ref->u.ar.type == AR_SECTION);
4096 for (n = 0; n < ref->u.ar.dimen; n++)
4098 /* Detect passing the full array as a section. This could do
4099 even more checking, but it doesn't seem worth it. */
4100 if (ref->u.ar.start[n]
4102 || (ref->u.ar.stride[n]
4103 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
4113 if (se->direct_byref)
4115 /* Copy the descriptor for pointer assignments. */
4116 gfc_add_modify_expr (&se->pre, se->expr, desc);
4118 else if (se->want_pointer)
4120 /* We pass full arrays directly. This means that pointers and
4121 allocatable arrays should also work. */
4122 se->expr = build_fold_addr_expr (desc);
4129 if (expr->ts.type == BT_CHARACTER)
4130 se->string_length = gfc_get_expr_charlen (expr);
4137 /* A transformational function return value will be a temporary
4138 array descriptor. We still need to go through the scalarizer
4139 to create the descriptor. Elemental functions ar handled as
4140 arbitrary expressions, i.e. copy to a temporary. */
4142 /* Look for the SS for this function. */
4143 while (secss != gfc_ss_terminator
4144 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4145 secss = secss->next;
4147 if (se->direct_byref)
4149 gcc_assert (secss != gfc_ss_terminator);
4151 /* For pointer assignments pass the descriptor directly. */
4153 se->expr = build_fold_addr_expr (se->expr);
4154 gfc_conv_expr (se, expr);
4158 if (secss == gfc_ss_terminator)
4160 /* Elemental function. */
4166 /* Transformational function. */
4167 info = &secss->data.info;
4173 /* Something complicated. Copy it into a temporary. */
4181 gfc_init_loopinfo (&loop);
4183 /* Associate the SS with the loop. */
4184 gfc_add_ss_to_loop (&loop, ss);
4186 /* Tell the scalarizer not to bother creating loop variables, etc. */
4188 loop.array_parameter = 1;
4190 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4191 gcc_assert (!se->direct_byref);
4193 /* Setup the scalarizing loops and bounds. */
4194 gfc_conv_ss_startstride (&loop);
4198 /* Tell the scalarizer to make a temporary. */
4199 loop.temp_ss = gfc_get_ss ();
4200 loop.temp_ss->type = GFC_SS_TEMP;
4201 loop.temp_ss->next = gfc_ss_terminator;
4202 if (expr->ts.type == BT_CHARACTER)
4204 if (expr->ts.cl == NULL)
4206 /* This had better be a substring reference! */
4207 gfc_ref *char_ref = expr->ref;
4208 for (; char_ref; char_ref = char_ref->next)
4209 if (char_ref->type == REF_SUBSTRING)
4212 expr->ts.cl = gfc_get_charlen ();
4213 expr->ts.cl->next = char_ref->u.ss.length->next;
4214 char_ref->u.ss.length->next = expr->ts.cl;
4216 mpz_init_set_ui (char_len, 1);
4217 mpz_add (char_len, char_len,
4218 char_ref->u.ss.end->value.integer);
4219 mpz_sub (char_len, char_len,
4220 char_ref->u.ss.start->value.integer);
4221 expr->ts.cl->backend_decl
4222 = gfc_conv_mpz_to_tree (char_len,
4223 gfc_default_character_kind);
4224 /* Cast is necessary for *-charlen refs. */
4225 expr->ts.cl->backend_decl
4226 = convert (gfc_charlen_type_node,
4227 expr->ts.cl->backend_decl);
4228 mpz_clear (char_len);
4231 gcc_assert (char_ref != NULL);
4232 loop.temp_ss->data.temp.type
4233 = gfc_typenode_for_spec (&expr->ts);
4234 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4236 else if (expr->ts.cl->length
4237 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4239 expr->ts.cl->backend_decl
4240 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4241 expr->ts.cl->length->ts.kind);
4242 loop.temp_ss->data.temp.type
4243 = gfc_typenode_for_spec (&expr->ts);
4244 loop.temp_ss->string_length
4245 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4249 loop.temp_ss->data.temp.type
4250 = gfc_typenode_for_spec (&expr->ts);
4251 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4253 se->string_length = loop.temp_ss->string_length;
4257 loop.temp_ss->data.temp.type
4258 = gfc_typenode_for_spec (&expr->ts);
4259 loop.temp_ss->string_length = NULL;
4261 loop.temp_ss->data.temp.dimen = loop.dimen;
4262 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4265 gfc_conv_loop_setup (&loop);
4269 /* Copy into a temporary and pass that. We don't need to copy the data
4270 back because expressions and vector subscripts must be INTENT_IN. */
4271 /* TODO: Optimize passing function return values. */
4275 /* Start the copying loops. */
4276 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4277 gfc_mark_ss_chain_used (ss, 1);
4278 gfc_start_scalarized_body (&loop, &block);
4280 /* Copy each data element. */
4281 gfc_init_se (&lse, NULL);
4282 gfc_copy_loopinfo_to_se (&lse, &loop);
4283 gfc_init_se (&rse, NULL);
4284 gfc_copy_loopinfo_to_se (&rse, &loop);
4286 lse.ss = loop.temp_ss;
4289 gfc_conv_scalarized_array_ref (&lse, NULL);
4290 if (expr->ts.type == BT_CHARACTER)
4292 gfc_conv_expr (&rse, expr);
4293 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4294 rse.expr = build_fold_indirect_ref (rse.expr);
4297 gfc_conv_expr_val (&rse, expr);
4299 gfc_add_block_to_block (&block, &rse.pre);
4300 gfc_add_block_to_block (&block, &lse.pre);
4302 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4304 /* Finish the copying loops. */
4305 gfc_trans_scalarizing_loops (&loop, &block);
4307 desc = loop.temp_ss->data.info.descriptor;
4309 gcc_assert (is_gimple_lvalue (desc));
4311 else if (expr->expr_type == EXPR_FUNCTION)
4313 desc = info->descriptor;
4314 se->string_length = ss->string_length;
4318 /* We pass sections without copying to a temporary. Make a new
4319 descriptor and point it at the section we want. The loop variable
4320 limits will be the limits of the section.
4321 A function may decide to repack the array to speed up access, but
4322 we're not bothered about that here. */
4331 /* Set the string_length for a character array. */
4332 if (expr->ts.type == BT_CHARACTER)
4333 se->string_length = gfc_get_expr_charlen (expr);
4335 desc = info->descriptor;
4336 gcc_assert (secss && secss != gfc_ss_terminator);
4337 if (se->direct_byref)
4339 /* For pointer assignments we fill in the destination. */
4341 parmtype = TREE_TYPE (parm);
4345 /* Otherwise make a new one. */
4346 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4347 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4348 loop.from, loop.to, 0);
4349 parm = gfc_create_var (parmtype, "parm");
4352 offset = gfc_index_zero_node;
4355 /* The following can be somewhat confusing. We have two
4356 descriptors, a new one and the original array.
4357 {parm, parmtype, dim} refer to the new one.
4358 {desc, type, n, secss, loop} refer to the original, which maybe
4359 a descriptorless array.
4360 The bounds of the scalarization are the bounds of the section.
4361 We don't have to worry about numeric overflows when calculating
4362 the offsets because all elements are within the array data. */
4364 /* Set the dtype. */
4365 tmp = gfc_conv_descriptor_dtype (parm);
4366 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4368 if (se->direct_byref)
4369 base = gfc_index_zero_node;
4373 for (n = 0; n < info->ref->u.ar.dimen; n++)
4375 stride = gfc_conv_array_stride (desc, n);
4377 /* Work out the offset. */
4378 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4380 gcc_assert (info->subscript[n]
4381 && info->subscript[n]->type == GFC_SS_SCALAR);
4382 start = info->subscript[n]->data.scalar.expr;
4386 /* Check we haven't somehow got out of sync. */
4387 gcc_assert (info->dim[dim] == n);
4389 /* Evaluate and remember the start of the section. */
4390 start = info->start[dim];
4391 stride = gfc_evaluate_now (stride, &loop.pre);
4394 tmp = gfc_conv_array_lbound (desc, n);
4395 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4397 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4398 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4400 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4402 /* For elemental dimensions, we only need the offset. */
4406 /* Vector subscripts need copying and are handled elsewhere. */
4407 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4409 /* Set the new lower bound. */
4410 from = loop.from[dim];
4413 /* If we have an array section or are assigning to a pointer,
4414 make sure that the lower bound is 1. References to the full
4415 array should otherwise keep the original bounds. */
4416 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4417 && !integer_onep (from))
4419 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4420 gfc_index_one_node, from);
4421 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4422 from = gfc_index_one_node;
4424 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4425 gfc_add_modify_expr (&loop.pre, tmp, from);
4427 /* Set the new upper bound. */
4428 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4429 gfc_add_modify_expr (&loop.pre, tmp, to);
4431 /* Multiply the stride by the section stride to get the
4433 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4434 stride, info->stride[dim]);
4436 if (se->direct_byref)
4437 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4440 /* Store the new stride. */
4441 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4442 gfc_add_modify_expr (&loop.pre, tmp, stride);
4447 if (se->data_not_needed)
4448 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4451 /* Point the data pointer at the first element in the section. */
4452 tmp = gfc_conv_array_data (desc);
4453 tmp = build_fold_indirect_ref (tmp);
4454 tmp = gfc_build_array_ref (tmp, offset);
4455 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4456 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4459 if (se->direct_byref && !se->data_not_needed)
4461 /* Set the offset. */
4462 tmp = gfc_conv_descriptor_offset (parm);
4463 gfc_add_modify_expr (&loop.pre, tmp, base);
4467 /* Only the callee knows what the correct offset it, so just set
4469 tmp = gfc_conv_descriptor_offset (parm);
4470 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4475 if (!se->direct_byref)
4477 /* Get a pointer to the new descriptor. */
4478 if (se->want_pointer)
4479 se->expr = build_fold_addr_expr (desc);
4484 gfc_add_block_to_block (&se->pre, &loop.pre);
4485 gfc_add_block_to_block (&se->post, &loop.post);
4487 /* Cleanup the scalarizer. */
4488 gfc_cleanup_loop (&loop);
4492 /* Convert an array for passing as an actual parameter. */
4493 /* TODO: Optimize passing g77 arrays. */
4496 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4505 /* Passing address of the array if it is not pointer or assumed-shape. */
4506 if (expr->expr_type == EXPR_VARIABLE
4507 && expr->ref->u.ar.type == AR_FULL && g77)
4509 sym = expr->symtree->n.sym;
4510 tmp = gfc_get_symbol_decl (sym);
4512 if (sym->ts.type == BT_CHARACTER)
4513 se->string_length = sym->ts.cl->backend_decl;
4514 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4515 && !sym->attr.allocatable)
4517 /* Some variables are declared directly, others are declared as
4518 pointers and allocated on the heap. */
4519 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4522 se->expr = build_fold_addr_expr (tmp);
4525 if (sym->attr.allocatable)
4527 if (sym->attr.dummy)
4529 gfc_conv_expr_descriptor (se, expr, ss);
4530 se->expr = gfc_conv_array_data (se->expr);
4533 se->expr = gfc_conv_array_data (tmp);
4538 se->want_pointer = 1;
4539 gfc_conv_expr_descriptor (se, expr, ss);
4544 /* Repack the array. */
4545 tmp = gfc_chainon_list (NULL_TREE, desc);
4546 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4547 ptr = gfc_evaluate_now (ptr, &se->pre);
4550 gfc_start_block (&block);
4552 /* Copy the data back. */
4553 tmp = gfc_chainon_list (NULL_TREE, desc);
4554 tmp = gfc_chainon_list (tmp, ptr);
4555 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4556 gfc_add_expr_to_block (&block, tmp);
4558 /* Free the temporary. */
4559 tmp = convert (pvoid_type_node, ptr);
4560 tmp = gfc_chainon_list (NULL_TREE, tmp);
4561 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4562 gfc_add_expr_to_block (&block, tmp);
4564 stmt = gfc_finish_block (&block);
4566 gfc_init_block (&block);
4567 /* Only if it was repacked. This code needs to be executed before the
4568 loop cleanup code. */
4569 tmp = build_fold_indirect_ref (desc);
4570 tmp = gfc_conv_array_data (tmp);
4571 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4572 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4574 gfc_add_expr_to_block (&block, tmp);
4575 gfc_add_block_to_block (&block, &se->post);
4577 gfc_init_block (&se->post);
4578 gfc_add_block_to_block (&se->post, &block);
4583 /* Generate code to deallocate an array, if it is allocated. */
4586 gfc_trans_dealloc_allocated (tree descriptor)
4592 gfc_start_block (&block);
4593 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4595 tmp = gfc_conv_descriptor_data_get (descriptor);
4596 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4597 build_int_cst (TREE_TYPE (tmp), 0));
4598 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4599 gfc_add_expr_to_block (&block, tmp);
4601 tmp = gfc_finish_block (&block);
4607 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4610 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4615 stmtblock_t fnblock;
4618 /* Make sure the frontend gets these right. */
4619 if (!(sym->attr.pointer || sym->attr.allocatable))
4621 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4623 gfc_init_block (&fnblock);
4625 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4626 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4628 if (sym->ts.type == BT_CHARACTER
4629 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4631 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4632 gfc_trans_vla_type_sizes (sym, &fnblock);
4635 /* Dummy and use associated variables don't need anything special. */
4636 if (sym->attr.dummy || sym->attr.use_assoc)
4638 gfc_add_expr_to_block (&fnblock, body);
4640 return gfc_finish_block (&fnblock);
4643 gfc_get_backend_locus (&loc);
4644 gfc_set_backend_locus (&sym->declared_at);
4645 descriptor = sym->backend_decl;
4647 if (TREE_STATIC (descriptor))
4649 /* SAVEd variables are not freed on exit. */
4650 gfc_trans_static_array_pointer (sym);
4654 /* Get the descriptor type. */
4655 type = TREE_TYPE (sym->backend_decl);
4656 if (!GFC_DESCRIPTOR_TYPE_P (type))
4658 /* If the backend_decl is not a descriptor, we must have a pointer
4660 descriptor = build_fold_indirect_ref (sym->backend_decl);
4661 type = TREE_TYPE (descriptor);
4662 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4665 /* NULLIFY the data pointer. */
4666 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4668 gfc_add_expr_to_block (&fnblock, body);
4670 gfc_set_backend_locus (&loc);
4671 /* Allocatable arrays need to be freed when they go out of scope. */
4672 if (sym->attr.allocatable)
4674 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4675 gfc_add_expr_to_block (&fnblock, tmp);
4678 return gfc_finish_block (&fnblock);
4681 /************ Expression Walking Functions ******************/
4683 /* Walk a variable reference.
4685 Possible extension - multiple component subscripts.
4686 x(:,:) = foo%a(:)%b(:)
4688 forall (i=..., j=...)
4689 x(i,j) = foo%a(j)%b(i)
4691 This adds a fair amout of complexity because you need to deal with more
4692 than one ref. Maybe handle in a similar manner to vector subscripts.
4693 Maybe not worth the effort. */
4697 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4705 for (ref = expr->ref; ref; ref = ref->next)
4706 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4709 for (; ref; ref = ref->next)
4711 if (ref->type == REF_SUBSTRING)
4713 newss = gfc_get_ss ();
4714 newss->type = GFC_SS_SCALAR;
4715 newss->expr = ref->u.ss.start;
4719 newss = gfc_get_ss ();
4720 newss->type = GFC_SS_SCALAR;
4721 newss->expr = ref->u.ss.end;
4726 /* We're only interested in array sections from now on. */
4727 if (ref->type != REF_ARRAY)
4734 for (n = 0; n < ar->dimen; n++)
4736 newss = gfc_get_ss ();
4737 newss->type = GFC_SS_SCALAR;
4738 newss->expr = ar->start[n];
4745 newss = gfc_get_ss ();
4746 newss->type = GFC_SS_SECTION;
4749 newss->data.info.dimen = ar->as->rank;
4750 newss->data.info.ref = ref;
4752 /* Make sure array is the same as array(:,:), this way
4753 we don't need to special case all the time. */
4754 ar->dimen = ar->as->rank;
4755 for (n = 0; n < ar->dimen; n++)
4757 newss->data.info.dim[n] = n;
4758 ar->dimen_type[n] = DIMEN_RANGE;
4760 gcc_assert (ar->start[n] == NULL);
4761 gcc_assert (ar->end[n] == NULL);
4762 gcc_assert (ar->stride[n] == NULL);
4768 newss = gfc_get_ss ();
4769 newss->type = GFC_SS_SECTION;
4772 newss->data.info.dimen = 0;
4773 newss->data.info.ref = ref;
4777 /* We add SS chains for all the subscripts in the section. */
4778 for (n = 0; n < ar->dimen; n++)
4782 switch (ar->dimen_type[n])
4785 /* Add SS for elemental (scalar) subscripts. */
4786 gcc_assert (ar->start[n]);
4787 indexss = gfc_get_ss ();
4788 indexss->type = GFC_SS_SCALAR;
4789 indexss->expr = ar->start[n];
4790 indexss->next = gfc_ss_terminator;
4791 indexss->loop_chain = gfc_ss_terminator;
4792 newss->data.info.subscript[n] = indexss;
4796 /* We don't add anything for sections, just remember this
4797 dimension for later. */
4798 newss->data.info.dim[newss->data.info.dimen] = n;
4799 newss->data.info.dimen++;
4803 /* Create a GFC_SS_VECTOR index in which we can store
4804 the vector's descriptor. */
4805 indexss = gfc_get_ss ();
4806 indexss->type = GFC_SS_VECTOR;
4807 indexss->expr = ar->start[n];
4808 indexss->next = gfc_ss_terminator;
4809 indexss->loop_chain = gfc_ss_terminator;
4810 newss->data.info.subscript[n] = indexss;
4811 newss->data.info.dim[newss->data.info.dimen] = n;
4812 newss->data.info.dimen++;
4816 /* We should know what sort of section it is by now. */
4820 /* We should have at least one non-elemental dimension. */
4821 gcc_assert (newss->data.info.dimen > 0);
4826 /* We should know what sort of section it is by now. */
4835 /* Walk an expression operator. If only one operand of a binary expression is
4836 scalar, we must also add the scalar term to the SS chain. */
4839 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4845 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4846 if (expr->value.op.op2 == NULL)
4849 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4851 /* All operands are scalar. Pass back and let the caller deal with it. */
4855 /* All operands require scalarization. */
4856 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4859 /* One of the operands needs scalarization, the other is scalar.
4860 Create a gfc_ss for the scalar expression. */
4861 newss = gfc_get_ss ();
4862 newss->type = GFC_SS_SCALAR;
4865 /* First operand is scalar. We build the chain in reverse order, so
4866 add the scarar SS after the second operand. */
4868 while (head && head->next != ss)
4870 /* Check we haven't somehow broken the chain. */
4874 newss->expr = expr->value.op.op1;
4876 else /* head2 == head */
4878 gcc_assert (head2 == head);
4879 /* Second operand is scalar. */
4880 newss->next = head2;
4882 newss->expr = expr->value.op.op2;
4889 /* Reverse a SS chain. */
4892 gfc_reverse_ss (gfc_ss * ss)
4897 gcc_assert (ss != NULL);
4899 head = gfc_ss_terminator;
4900 while (ss != gfc_ss_terminator)
4903 /* Check we didn't somehow break the chain. */
4904 gcc_assert (next != NULL);
4914 /* Walk the arguments of an elemental function. */
4917 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4925 head = gfc_ss_terminator;
4928 for (; arg; arg = arg->next)
4933 newss = gfc_walk_subexpr (head, arg->expr);
4936 /* Scalar argument. */
4937 newss = gfc_get_ss ();
4939 newss->expr = arg->expr;
4949 while (tail->next != gfc_ss_terminator)
4956 /* If all the arguments are scalar we don't need the argument SS. */
4957 gfc_free_ss_chain (head);
4962 /* Add it onto the existing chain. */
4968 /* Walk a function call. Scalar functions are passed back, and taken out of
4969 scalarization loops. For elemental functions we walk their arguments.
4970 The result of functions returning arrays is stored in a temporary outside
4971 the loop, so that the function is only called once. Hence we do not need
4972 to walk their arguments. */
4975 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4978 gfc_intrinsic_sym *isym;
4981 isym = expr->value.function.isym;
4983 /* Handle intrinsic functions separately. */
4985 return gfc_walk_intrinsic_function (ss, expr, isym);
4987 sym = expr->value.function.esym;
4989 sym = expr->symtree->n.sym;
4991 /* A function that returns arrays. */
4992 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4994 newss = gfc_get_ss ();
4995 newss->type = GFC_SS_FUNCTION;
4998 newss->data.info.dimen = expr->rank;
5002 /* Walk the parameters of an elemental function. For now we always pass
5004 if (sym->attr.elemental)
5005 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5008 /* Scalar functions are OK as these are evaluated outside the scalarization
5009 loop. Pass back and let the caller deal with it. */
5014 /* An array temporary is constructed for array constructors. */
5017 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5022 newss = gfc_get_ss ();
5023 newss->type = GFC_SS_CONSTRUCTOR;
5026 newss->data.info.dimen = expr->rank;
5027 for (n = 0; n < expr->rank; n++)
5028 newss->data.info.dim[n] = n;
5034 /* Walk an expression. Add walked expressions to the head of the SS chain.
5035 A wholly scalar expression will not be added. */
5038 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5042 switch (expr->expr_type)
5045 head = gfc_walk_variable_expr (ss, expr);
5049 head = gfc_walk_op_expr (ss, expr);
5053 head = gfc_walk_function_expr (ss, expr);
5058 case EXPR_STRUCTURE:
5059 /* Pass back and let the caller deal with it. */
5063 head = gfc_walk_array_constructor (ss, expr);
5066 case EXPR_SUBSTRING:
5067 /* Pass back and let the caller deal with it. */
5071 internal_error ("bad expression type during walk (%d)",
5078 /* Entry point for expression walking.
5079 A return value equal to the passed chain means this is
5080 a scalar expression. It is up to the caller to take whatever action is
5081 necessary to translate these. */
5084 gfc_walk_expr (gfc_expr * expr)
5088 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5089 return gfc_reverse_ss (res);