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. */
1257 loopbody = gfc_finish_block (&body);
1259 gfc_init_se (&se, NULL);
1260 gfc_conv_expr (&se, c->iterator->var);
1261 gfc_add_block_to_block (pblock, &se.pre);
1264 /* Make a temporary, store the current value in that
1265 and return it, once the loop is done. */
1266 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1267 gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
1269 /* Initialize the loop. */
1270 gfc_init_se (&se, NULL);
1271 gfc_conv_expr_val (&se, c->iterator->start);
1272 gfc_add_block_to_block (pblock, &se.pre);
1273 gfc_add_modify_expr (pblock, loopvar, se.expr);
1275 gfc_init_se (&se, NULL);
1276 gfc_conv_expr_val (&se, c->iterator->end);
1277 gfc_add_block_to_block (pblock, &se.pre);
1278 end = gfc_evaluate_now (se.expr, pblock);
1280 gfc_init_se (&se, NULL);
1281 gfc_conv_expr_val (&se, c->iterator->step);
1282 gfc_add_block_to_block (pblock, &se.pre);
1283 step = gfc_evaluate_now (se.expr, pblock);
1285 /* If this array expands dynamically, and the number of iterations
1286 is not constant, we won't have allocated space for the static
1287 part of C->EXPR's size. Do that now. */
1288 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1290 /* Get the number of iterations. */
1291 tmp = gfc_get_iteration_count (loopvar, end, step);
1293 /* Get the static part of C->EXPR's size. */
1294 gfc_get_array_constructor_element_size (&size, c->expr);
1295 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1297 /* Grow the array by TMP * TMP2 elements. */
1298 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1299 gfc_grow_array (pblock, desc, tmp);
1302 /* Generate the loop body. */
1303 exit_label = gfc_build_label_decl (NULL_TREE);
1304 gfc_start_block (&body);
1306 /* Generate the exit condition. Depending on the sign of
1307 the step variable we have to generate the correct
1309 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1310 build_int_cst (TREE_TYPE (step), 0));
1311 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1312 build2 (GT_EXPR, boolean_type_node,
1314 build2 (LT_EXPR, boolean_type_node,
1316 tmp = build1_v (GOTO_EXPR, exit_label);
1317 TREE_USED (exit_label) = 1;
1318 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1319 gfc_add_expr_to_block (&body, tmp);
1321 /* The main loop body. */
1322 gfc_add_expr_to_block (&body, loopbody);
1324 /* Increase loop variable by step. */
1325 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1326 gfc_add_modify_expr (&body, loopvar, tmp);
1328 /* Finish the loop. */
1329 tmp = gfc_finish_block (&body);
1330 tmp = build1_v (LOOP_EXPR, tmp);
1331 gfc_add_expr_to_block (pblock, tmp);
1333 /* Add the exit label. */
1334 tmp = build1_v (LABEL_EXPR, exit_label);
1335 gfc_add_expr_to_block (pblock, tmp);
1337 /* Restore the original value of the loop counter. */
1338 gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
1345 /* Figure out the string length of a variable reference expression.
1346 Used by get_array_ctor_strlen. */
1349 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1355 /* Don't bother if we already know the length is a constant. */
1356 if (*len && INTEGER_CST_P (*len))
1359 ts = &expr->symtree->n.sym->ts;
1360 for (ref = expr->ref; ref; ref = ref->next)
1365 /* Array references don't change the string length. */
1369 /* Use the length of the component. */
1370 ts = &ref->u.c.component->ts;
1374 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1375 || ref->u.ss.start->expr_type != EXPR_CONSTANT)
1377 mpz_init_set_ui (char_len, 1);
1378 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1379 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1380 *len = gfc_conv_mpz_to_tree (char_len,
1381 gfc_default_character_kind);
1382 *len = convert (gfc_charlen_type_node, *len);
1383 mpz_clear (char_len);
1387 /* TODO: Substrings are tricky because we can't evaluate the
1388 expression more than once. For now we just give up, and hope
1389 we can figure it out elsewhere. */
1394 *len = ts->cl->backend_decl;
1398 /* Figure out the string length of a character array constructor.
1399 Returns TRUE if all elements are character constants. */
1402 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1407 for (; c; c = c->next)
1409 switch (c->expr->expr_type)
1412 if (!(*len && INTEGER_CST_P (*len)))
1413 *len = build_int_cstu (gfc_charlen_type_node,
1414 c->expr->value.character.length);
1418 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1424 get_array_ctor_var_strlen (c->expr, len);
1429 /* TODO: For now we just ignore anything we don't know how to
1430 handle, and hope we can figure it out a different way. */
1439 /* Array constructors are handled by constructing a temporary, then using that
1440 within the scalarization loop. This is not optimal, but seems by far the
1444 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1454 ss->data.info.dimen = loop->dimen;
1456 c = ss->expr->value.constructor;
1457 if (ss->expr->ts.type == BT_CHARACTER)
1459 const_string = get_array_ctor_strlen (c, &ss->string_length);
1460 if (!ss->string_length)
1461 gfc_todo_error ("complex character array constructors");
1463 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1465 type = build_pointer_type (type);
1469 const_string = TRUE;
1470 type = gfc_typenode_for_spec (&ss->expr->ts);
1473 /* See if the constructor determines the loop bounds. */
1475 if (loop->to[0] == NULL_TREE)
1479 /* We should have a 1-dimensional, zero-based loop. */
1480 gcc_assert (loop->dimen == 1);
1481 gcc_assert (integer_zerop (loop->from[0]));
1483 /* Split the constructor size into a static part and a dynamic part.
1484 Allocate the static size up-front and record whether the dynamic
1485 size might be nonzero. */
1487 dynamic = gfc_get_array_constructor_size (&size, c);
1488 mpz_sub_ui (size, size, 1);
1489 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1493 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1494 type, dynamic, true, false, false);
1496 desc = ss->data.info.descriptor;
1497 offset = gfc_index_zero_node;
1498 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1499 TREE_USED (offsetvar) = 0;
1500 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1501 &offset, &offsetvar, dynamic);
1503 /* If the array grows dynamically, the upper bound of the loop variable
1504 is determined by the array's final upper bound. */
1506 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1508 if (TREE_USED (offsetvar))
1509 pushdecl (offsetvar);
1511 gcc_assert (INTEGER_CST_P (offset));
1513 /* Disable bound checking for now because it's probably broken. */
1514 if (flag_bounds_check)
1522 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1523 called after evaluating all of INFO's vector dimensions. Go through
1524 each such vector dimension and see if we can now fill in any missing
1528 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1537 for (n = 0; n < loop->dimen; n++)
1540 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1541 && loop->to[n] == NULL)
1543 /* Loop variable N indexes vector dimension DIM, and we don't
1544 yet know the upper bound of loop variable N. Set it to the
1545 difference between the vector's upper and lower bounds. */
1546 gcc_assert (loop->from[n] == gfc_index_zero_node);
1547 gcc_assert (info->subscript[dim]
1548 && info->subscript[dim]->type == GFC_SS_VECTOR);
1550 gfc_init_se (&se, NULL);
1551 desc = info->subscript[dim]->data.info.descriptor;
1552 zero = gfc_rank_cst[0];
1553 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1554 gfc_conv_descriptor_ubound (desc, zero),
1555 gfc_conv_descriptor_lbound (desc, zero));
1556 tmp = gfc_evaluate_now (tmp, &loop->pre);
1563 /* Add the pre and post chains for all the scalar expressions in a SS chain
1564 to loop. This is called after the loop parameters have been calculated,
1565 but before the actual scalarizing loops. */
1568 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1573 /* TODO: This can generate bad code if there are ordering dependencies.
1574 eg. a callee allocated function and an unknown size constructor. */
1575 gcc_assert (ss != NULL);
1577 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1584 /* Scalar expression. Evaluate this now. This includes elemental
1585 dimension indices, but not array section bounds. */
1586 gfc_init_se (&se, NULL);
1587 gfc_conv_expr (&se, ss->expr);
1588 gfc_add_block_to_block (&loop->pre, &se.pre);
1590 if (ss->expr->ts.type != BT_CHARACTER)
1592 /* Move the evaluation of scalar expressions outside the
1593 scalarization loop. */
1595 se.expr = convert(gfc_array_index_type, se.expr);
1596 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1597 gfc_add_block_to_block (&loop->pre, &se.post);
1600 gfc_add_block_to_block (&loop->post, &se.post);
1602 ss->data.scalar.expr = se.expr;
1603 ss->string_length = se.string_length;
1606 case GFC_SS_REFERENCE:
1607 /* Scalar reference. Evaluate this now. */
1608 gfc_init_se (&se, NULL);
1609 gfc_conv_expr_reference (&se, ss->expr);
1610 gfc_add_block_to_block (&loop->pre, &se.pre);
1611 gfc_add_block_to_block (&loop->post, &se.post);
1613 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1614 ss->string_length = se.string_length;
1617 case GFC_SS_SECTION:
1618 /* Add the expressions for scalar and vector subscripts. */
1619 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1620 if (ss->data.info.subscript[n])
1621 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1623 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1627 /* Get the vector's descriptor and store it in SS. */
1628 gfc_init_se (&se, NULL);
1629 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1630 gfc_add_block_to_block (&loop->pre, &se.pre);
1631 gfc_add_block_to_block (&loop->post, &se.post);
1632 ss->data.info.descriptor = se.expr;
1635 case GFC_SS_INTRINSIC:
1636 gfc_add_intrinsic_ss_code (loop, ss);
1639 case GFC_SS_FUNCTION:
1640 /* Array function return value. We call the function and save its
1641 result in a temporary for use inside the loop. */
1642 gfc_init_se (&se, NULL);
1645 gfc_conv_expr (&se, ss->expr);
1646 gfc_add_block_to_block (&loop->pre, &se.pre);
1647 gfc_add_block_to_block (&loop->post, &se.post);
1648 ss->string_length = se.string_length;
1651 case GFC_SS_CONSTRUCTOR:
1652 gfc_trans_array_constructor (loop, ss);
1656 case GFC_SS_COMPONENT:
1657 /* Do nothing. These are handled elsewhere. */
1667 /* Translate expressions for the descriptor and data pointer of a SS. */
1671 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1676 /* Get the descriptor for the array to be scalarized. */
1677 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1678 gfc_init_se (&se, NULL);
1679 se.descriptor_only = 1;
1680 gfc_conv_expr_lhs (&se, ss->expr);
1681 gfc_add_block_to_block (block, &se.pre);
1682 ss->data.info.descriptor = se.expr;
1683 ss->string_length = se.string_length;
1687 /* Also the data pointer. */
1688 tmp = gfc_conv_array_data (se.expr);
1689 /* If this is a variable or address of a variable we use it directly.
1690 Otherwise we must evaluate it now to avoid breaking dependency
1691 analysis by pulling the expressions for elemental array indices
1694 || (TREE_CODE (tmp) == ADDR_EXPR
1695 && DECL_P (TREE_OPERAND (tmp, 0)))))
1696 tmp = gfc_evaluate_now (tmp, block);
1697 ss->data.info.data = tmp;
1699 tmp = gfc_conv_array_offset (se.expr);
1700 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1705 /* Initialize a gfc_loopinfo structure. */
1708 gfc_init_loopinfo (gfc_loopinfo * loop)
1712 memset (loop, 0, sizeof (gfc_loopinfo));
1713 gfc_init_block (&loop->pre);
1714 gfc_init_block (&loop->post);
1716 /* Initially scalarize in order. */
1717 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1720 loop->ss = gfc_ss_terminator;
1724 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1728 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1734 /* Return an expression for the data pointer of an array. */
1737 gfc_conv_array_data (tree descriptor)
1741 type = TREE_TYPE (descriptor);
1742 if (GFC_ARRAY_TYPE_P (type))
1744 if (TREE_CODE (type) == POINTER_TYPE)
1748 /* Descriptorless arrays. */
1749 return build_fold_addr_expr (descriptor);
1753 return gfc_conv_descriptor_data_get (descriptor);
1757 /* Return an expression for the base offset of an array. */
1760 gfc_conv_array_offset (tree descriptor)
1764 type = TREE_TYPE (descriptor);
1765 if (GFC_ARRAY_TYPE_P (type))
1766 return GFC_TYPE_ARRAY_OFFSET (type);
1768 return gfc_conv_descriptor_offset (descriptor);
1772 /* Get an expression for the array stride. */
1775 gfc_conv_array_stride (tree descriptor, int dim)
1780 type = TREE_TYPE (descriptor);
1782 /* For descriptorless arrays use the array size. */
1783 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1784 if (tmp != NULL_TREE)
1787 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1792 /* Like gfc_conv_array_stride, but for the lower bound. */
1795 gfc_conv_array_lbound (tree descriptor, int dim)
1800 type = TREE_TYPE (descriptor);
1802 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1803 if (tmp != NULL_TREE)
1806 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1811 /* Like gfc_conv_array_stride, but for the upper bound. */
1814 gfc_conv_array_ubound (tree descriptor, int dim)
1819 type = TREE_TYPE (descriptor);
1821 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1822 if (tmp != NULL_TREE)
1825 /* This should only ever happen when passing an assumed shape array
1826 as an actual parameter. The value will never be used. */
1827 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1828 return gfc_index_zero_node;
1830 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1835 /* Generate code to perform an array index bound check. */
1838 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
1845 if (!flag_bounds_check)
1848 index = gfc_evaluate_now (index, &se->pre);
1850 /* Check lower bound. */
1851 tmp = gfc_conv_array_lbound (descriptor, n);
1852 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1854 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
1855 gfc_msg_fault, se->ss->expr->symtree->name, n+1);
1857 asprintf (&msg, "%s, lower bound of dimension %d exceeded",
1858 gfc_msg_fault, n+1);
1859 gfc_trans_runtime_check (fault, msg, &se->pre, where);
1862 /* Check upper bound. */
1863 tmp = gfc_conv_array_ubound (descriptor, n);
1864 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1866 asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
1867 gfc_msg_fault, se->ss->expr->symtree->name, n+1);
1869 asprintf (&msg, "%s, upper bound of dimension %d exceeded",
1870 gfc_msg_fault, n+1);
1871 gfc_trans_runtime_check (fault, msg, &se->pre, where);
1878 /* Return the offset for an index. Performs bound checking for elemental
1879 dimensions. Single element references are processed separately. */
1882 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1883 gfc_array_ref * ar, tree stride)
1889 /* Get the index into the array for this dimension. */
1892 gcc_assert (ar->type != AR_ELEMENT);
1893 switch (ar->dimen_type[dim])
1896 gcc_assert (i == -1);
1897 /* Elemental dimension. */
1898 gcc_assert (info->subscript[dim]
1899 && info->subscript[dim]->type == GFC_SS_SCALAR);
1900 /* We've already translated this value outside the loop. */
1901 index = info->subscript[dim]->data.scalar.expr;
1903 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
1904 || dim < ar->dimen - 1)
1905 index = gfc_trans_array_bound_check (se, info->descriptor,
1906 index, dim, &ar->where);
1910 gcc_assert (info && se->loop);
1911 gcc_assert (info->subscript[dim]
1912 && info->subscript[dim]->type == GFC_SS_VECTOR);
1913 desc = info->subscript[dim]->data.info.descriptor;
1915 /* Get a zero-based index into the vector. */
1916 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1917 se->loop->loopvar[i], se->loop->from[i]);
1919 /* Multiply the index by the stride. */
1920 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1921 index, gfc_conv_array_stride (desc, 0));
1923 /* Read the vector to get an index into info->descriptor. */
1924 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1925 index = gfc_build_array_ref (data, index);
1926 index = gfc_evaluate_now (index, &se->pre);
1928 /* Do any bounds checking on the final info->descriptor index. */
1929 if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
1930 || dim < ar->dimen - 1)
1931 index = gfc_trans_array_bound_check (se, info->descriptor,
1932 index, dim, &ar->where);
1936 /* Scalarized dimension. */
1937 gcc_assert (info && se->loop);
1939 /* Multiply the loop variable by the stride and delta. */
1940 index = se->loop->loopvar[i];
1941 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1943 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1953 /* Temporary array or derived type component. */
1954 gcc_assert (se->loop);
1955 index = se->loop->loopvar[se->loop->order[i]];
1956 if (!integer_zerop (info->delta[i]))
1957 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1958 index, info->delta[i]);
1961 /* Multiply by the stride. */
1962 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1968 /* Build a scalarized reference to an array. */
1971 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1978 info = &se->ss->data.info;
1980 n = se->loop->order[0];
1984 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1986 /* Add the offset for this dimension to the stored offset for all other
1988 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1990 tmp = build_fold_indirect_ref (info->data);
1991 se->expr = gfc_build_array_ref (tmp, index);
1995 /* Translate access of temporary array. */
1998 gfc_conv_tmp_array_ref (gfc_se * se)
2000 se->string_length = se->ss->string_length;
2001 gfc_conv_scalarized_array_ref (se, NULL);
2005 /* Build an array reference. se->expr already holds the array descriptor.
2006 This should be either a variable, indirect variable reference or component
2007 reference. For arrays which do not have a descriptor, se->expr will be
2009 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2012 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2021 /* Handle scalarized references separately. */
2022 if (ar->type != AR_ELEMENT)
2024 gfc_conv_scalarized_array_ref (se, ar);
2025 gfc_advance_se_ss_chain (se);
2029 index = gfc_index_zero_node;
2031 /* Calculate the offsets from all the dimensions. */
2032 for (n = 0; n < ar->dimen; n++)
2034 /* Calculate the index for this dimension. */
2035 gfc_init_se (&indexse, se);
2036 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2037 gfc_add_block_to_block (&se->pre, &indexse.pre);
2039 if (flag_bounds_check &&
2040 ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
2041 || n < ar->dimen - 1))
2043 /* Check array bounds. */
2047 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
2049 tmp = gfc_conv_array_lbound (se->expr, n);
2050 cond = fold_build2 (LT_EXPR, boolean_type_node,
2052 asprintf (&msg, "%s for array '%s', "
2053 "lower bound of dimension %d exceeded", gfc_msg_fault,
2055 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2058 tmp = gfc_conv_array_ubound (se->expr, n);
2059 cond = fold_build2 (GT_EXPR, boolean_type_node,
2061 asprintf (&msg, "%s for array '%s', "
2062 "upper bound of dimension %d exceeded", gfc_msg_fault,
2064 gfc_trans_runtime_check (cond, msg, &se->pre, where);
2068 /* Multiply the index by the stride. */
2069 stride = gfc_conv_array_stride (se->expr, n);
2070 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2073 /* And add it to the total. */
2074 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2077 tmp = gfc_conv_array_offset (se->expr);
2078 if (!integer_zerop (tmp))
2079 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2081 /* Access the calculated element. */
2082 tmp = gfc_conv_array_data (se->expr);
2083 tmp = build_fold_indirect_ref (tmp);
2084 se->expr = gfc_build_array_ref (tmp, index);
2088 /* Generate the code to be executed immediately before entering a
2089 scalarization loop. */
2092 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2093 stmtblock_t * pblock)
2102 /* This code will be executed before entering the scalarization loop
2103 for this dimension. */
2104 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2106 if ((ss->useflags & flag) == 0)
2109 if (ss->type != GFC_SS_SECTION
2110 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2111 && ss->type != GFC_SS_COMPONENT)
2114 info = &ss->data.info;
2116 if (dim >= info->dimen)
2119 if (dim == info->dimen - 1)
2121 /* For the outermost loop calculate the offset due to any
2122 elemental dimensions. It will have been initialized with the
2123 base offset of the array. */
2126 for (i = 0; i < info->ref->u.ar.dimen; i++)
2128 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2131 gfc_init_se (&se, NULL);
2133 se.expr = info->descriptor;
2134 stride = gfc_conv_array_stride (info->descriptor, i);
2135 index = gfc_conv_array_index_offset (&se, info, i, -1,
2138 gfc_add_block_to_block (pblock, &se.pre);
2140 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2141 info->offset, index);
2142 info->offset = gfc_evaluate_now (info->offset, pblock);
2146 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2149 stride = gfc_conv_array_stride (info->descriptor, 0);
2151 /* Calculate the stride of the innermost loop. Hopefully this will
2152 allow the backend optimizers to do their stuff more effectively.
2154 info->stride0 = gfc_evaluate_now (stride, pblock);
2158 /* Add the offset for the previous loop dimension. */
2163 ar = &info->ref->u.ar;
2164 i = loop->order[dim + 1];
2172 gfc_init_se (&se, NULL);
2174 se.expr = info->descriptor;
2175 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2176 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2178 gfc_add_block_to_block (pblock, &se.pre);
2179 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2180 info->offset, index);
2181 info->offset = gfc_evaluate_now (info->offset, pblock);
2184 /* Remember this offset for the second loop. */
2185 if (dim == loop->temp_dim - 1)
2186 info->saved_offset = info->offset;
2191 /* Start a scalarized expression. Creates a scope and declares loop
2195 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2201 gcc_assert (!loop->array_parameter);
2203 for (dim = loop->dimen - 1; dim >= 0; dim--)
2205 n = loop->order[dim];
2207 gfc_start_block (&loop->code[n]);
2209 /* Create the loop variable. */
2210 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2212 if (dim < loop->temp_dim)
2216 /* Calculate values that will be constant within this loop. */
2217 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2219 gfc_start_block (pbody);
2223 /* Generates the actual loop code for a scalarization loop. */
2226 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2227 stmtblock_t * pbody)
2235 loopbody = gfc_finish_block (pbody);
2237 /* Initialize the loopvar. */
2238 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2240 exit_label = gfc_build_label_decl (NULL_TREE);
2242 /* Generate the loop body. */
2243 gfc_init_block (&block);
2245 /* The exit condition. */
2246 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2247 tmp = build1_v (GOTO_EXPR, exit_label);
2248 TREE_USED (exit_label) = 1;
2249 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2250 gfc_add_expr_to_block (&block, tmp);
2252 /* The main body. */
2253 gfc_add_expr_to_block (&block, loopbody);
2255 /* Increment the loopvar. */
2256 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2257 loop->loopvar[n], gfc_index_one_node);
2258 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2260 /* Build the loop. */
2261 tmp = gfc_finish_block (&block);
2262 tmp = build1_v (LOOP_EXPR, tmp);
2263 gfc_add_expr_to_block (&loop->code[n], tmp);
2265 /* Add the exit label. */
2266 tmp = build1_v (LABEL_EXPR, exit_label);
2267 gfc_add_expr_to_block (&loop->code[n], tmp);
2271 /* Finishes and generates the loops for a scalarized expression. */
2274 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2279 stmtblock_t *pblock;
2283 /* Generate the loops. */
2284 for (dim = 0; dim < loop->dimen; dim++)
2286 n = loop->order[dim];
2287 gfc_trans_scalarized_loop_end (loop, n, pblock);
2288 loop->loopvar[n] = NULL_TREE;
2289 pblock = &loop->code[n];
2292 tmp = gfc_finish_block (pblock);
2293 gfc_add_expr_to_block (&loop->pre, tmp);
2295 /* Clear all the used flags. */
2296 for (ss = loop->ss; ss; ss = ss->loop_chain)
2301 /* Finish the main body of a scalarized expression, and start the secondary
2305 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2309 stmtblock_t *pblock;
2313 /* We finish as many loops as are used by the temporary. */
2314 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2316 n = loop->order[dim];
2317 gfc_trans_scalarized_loop_end (loop, n, pblock);
2318 loop->loopvar[n] = NULL_TREE;
2319 pblock = &loop->code[n];
2322 /* We don't want to finish the outermost loop entirely. */
2323 n = loop->order[loop->temp_dim - 1];
2324 gfc_trans_scalarized_loop_end (loop, n, pblock);
2326 /* Restore the initial offsets. */
2327 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2329 if ((ss->useflags & 2) == 0)
2332 if (ss->type != GFC_SS_SECTION
2333 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2334 && ss->type != GFC_SS_COMPONENT)
2337 ss->data.info.offset = ss->data.info.saved_offset;
2340 /* Restart all the inner loops we just finished. */
2341 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2343 n = loop->order[dim];
2345 gfc_start_block (&loop->code[n]);
2347 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2349 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2352 /* Start a block for the secondary copying code. */
2353 gfc_start_block (body);
2357 /* Calculate the upper bound of an array section. */
2360 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2369 gcc_assert (ss->type == GFC_SS_SECTION);
2371 info = &ss->data.info;
2374 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2375 /* We'll calculate the upper bound once we have access to the
2376 vector's descriptor. */
2379 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2380 desc = info->descriptor;
2381 end = info->ref->u.ar.end[dim];
2385 /* The upper bound was specified. */
2386 gfc_init_se (&se, NULL);
2387 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2388 gfc_add_block_to_block (pblock, &se.pre);
2393 /* No upper bound was specified, so use the bound of the array. */
2394 bound = gfc_conv_array_ubound (desc, dim);
2401 /* Calculate the lower bound of an array section. */
2404 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2413 gcc_assert (ss->type == GFC_SS_SECTION);
2415 info = &ss->data.info;
2418 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2420 /* We use a zero-based index to access the vector. */
2421 info->start[n] = gfc_index_zero_node;
2422 info->stride[n] = gfc_index_one_node;
2426 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2427 desc = info->descriptor;
2428 start = info->ref->u.ar.start[dim];
2429 stride = info->ref->u.ar.stride[dim];
2431 /* Calculate the start of the range. For vector subscripts this will
2432 be the range of the vector. */
2435 /* Specified section start. */
2436 gfc_init_se (&se, NULL);
2437 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2438 gfc_add_block_to_block (&loop->pre, &se.pre);
2439 info->start[n] = se.expr;
2443 /* No lower bound specified so use the bound of the array. */
2444 info->start[n] = gfc_conv_array_lbound (desc, dim);
2446 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2448 /* Calculate the stride. */
2450 info->stride[n] = gfc_index_one_node;
2453 gfc_init_se (&se, NULL);
2454 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2455 gfc_add_block_to_block (&loop->pre, &se.pre);
2456 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2461 /* Calculates the range start and stride for a SS chain. Also gets the
2462 descriptor and data pointer. The range of vector subscripts is the size
2463 of the vector. Array bounds are also checked. */
2466 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2474 /* Determine the rank of the loop. */
2476 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2480 case GFC_SS_SECTION:
2481 case GFC_SS_CONSTRUCTOR:
2482 case GFC_SS_FUNCTION:
2483 case GFC_SS_COMPONENT:
2484 loop->dimen = ss->data.info.dimen;
2487 /* As usual, lbound and ubound are exceptions!. */
2488 case GFC_SS_INTRINSIC:
2489 switch (ss->expr->value.function.isym->generic_id)
2491 case GFC_ISYM_LBOUND:
2492 case GFC_ISYM_UBOUND:
2493 loop->dimen = ss->data.info.dimen;
2504 if (loop->dimen == 0)
2505 gfc_todo_error ("Unable to determine rank of expression");
2508 /* Loop over all the SS in the chain. */
2509 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2511 if (ss->expr && ss->expr->shape && !ss->shape)
2512 ss->shape = ss->expr->shape;
2516 case GFC_SS_SECTION:
2517 /* Get the descriptor for the array. */
2518 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2520 for (n = 0; n < ss->data.info.dimen; n++)
2521 gfc_conv_section_startstride (loop, ss, n);
2524 case GFC_SS_INTRINSIC:
2525 switch (ss->expr->value.function.isym->generic_id)
2527 /* Fall through to supply start and stride. */
2528 case GFC_ISYM_LBOUND:
2529 case GFC_ISYM_UBOUND:
2535 case GFC_SS_CONSTRUCTOR:
2536 case GFC_SS_FUNCTION:
2537 for (n = 0; n < ss->data.info.dimen; n++)
2539 ss->data.info.start[n] = gfc_index_zero_node;
2540 ss->data.info.stride[n] = gfc_index_one_node;
2549 /* The rest is just runtime bound checking. */
2550 if (flag_bounds_check)
2553 tree lbound, ubound;
2555 tree size[GFC_MAX_DIMENSIONS];
2556 tree stride_pos, stride_neg, non_zerosized, tmp2;
2561 gfc_start_block (&block);
2563 for (n = 0; n < loop->dimen; n++)
2564 size[n] = NULL_TREE;
2566 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2568 if (ss->type != GFC_SS_SECTION)
2571 /* TODO: range checking for mapped dimensions. */
2572 info = &ss->data.info;
2574 /* This code only checks ranges. Elemental and vector
2575 dimensions are checked later. */
2576 for (n = 0; n < loop->dimen; n++)
2579 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2581 if (n == info->ref->u.ar.dimen - 1
2582 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
2583 || info->ref->u.ar.as->cp_was_assumed))
2586 desc = ss->data.info.descriptor;
2588 /* This is the run-time equivalent of resolve.c's
2589 check_dimension(). The logical is more readable there
2590 than it is here, with all the trees. */
2591 lbound = gfc_conv_array_lbound (desc, dim);
2592 ubound = gfc_conv_array_ubound (desc, dim);
2593 end = gfc_conv_section_upper_bound (ss, n, &block);
2595 /* Zero stride is not allowed. */
2596 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
2597 gfc_index_zero_node);
2598 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
2599 "of array '%s'", info->dim[n]+1,
2600 ss->expr->symtree->name);
2601 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2604 /* non_zerosized is true when the selected range is not
2606 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
2607 info->stride[n], gfc_index_zero_node);
2608 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
2610 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2613 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
2614 info->stride[n], gfc_index_zero_node);
2615 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
2617 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2619 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2620 stride_pos, stride_neg);
2622 /* Check the start of the range against the lower and upper
2623 bounds of the array, if the range is not empty. */
2624 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
2626 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2627 non_zerosized, tmp);
2628 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
2629 " exceeded", gfc_msg_fault, info->dim[n]+1,
2630 ss->expr->symtree->name);
2631 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2634 tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n],
2636 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2637 non_zerosized, tmp);
2638 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2639 " exceeded", gfc_msg_fault, info->dim[n]+1,
2640 ss->expr->symtree->name);
2641 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2644 /* Compute the last element of the range, which is not
2645 necessarily "end" (think 0:5:3, which doesn't contain 5)
2646 and check it against both lower and upper bounds. */
2647 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2649 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
2651 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2654 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
2655 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2656 non_zerosized, tmp);
2657 asprintf (&msg, "%s, lower 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 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
2664 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2665 non_zerosized, tmp);
2666 asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
2667 " exceeded", gfc_msg_fault, info->dim[n]+1,
2668 ss->expr->symtree->name);
2669 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2672 /* Check the section sizes match. */
2673 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2675 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2677 /* We remember the size of the first section, and check all the
2678 others against this. */
2682 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2683 asprintf (&msg, "%s, size mismatch for dimension %d "
2684 "of array '%s'", gfc_msg_bounds, info->dim[n]+1,
2685 ss->expr->symtree->name);
2686 gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
2690 size[n] = gfc_evaluate_now (tmp, &block);
2694 tmp = gfc_finish_block (&block);
2695 gfc_add_expr_to_block (&loop->pre, tmp);
2700 /* Return true if the two SS could be aliased, i.e. both point to the same data
2702 /* TODO: resolve aliases based on frontend expressions. */
2705 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2712 lsym = lss->expr->symtree->n.sym;
2713 rsym = rss->expr->symtree->n.sym;
2714 if (gfc_symbols_could_alias (lsym, rsym))
2717 if (rsym->ts.type != BT_DERIVED
2718 && lsym->ts.type != BT_DERIVED)
2721 /* For derived types we must check all the component types. We can ignore
2722 array references as these will have the same base type as the previous
2724 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2726 if (lref->type != REF_COMPONENT)
2729 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2732 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2735 if (rref->type != REF_COMPONENT)
2738 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2743 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2745 if (rref->type != REF_COMPONENT)
2748 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2756 /* Resolve array data dependencies. Creates a temporary if required. */
2757 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2761 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2771 loop->temp_ss = NULL;
2772 aref = dest->data.info.ref;
2775 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2777 if (ss->type != GFC_SS_SECTION)
2780 if (gfc_could_be_alias (dest, ss)
2781 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2787 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2789 lref = dest->expr->ref;
2790 rref = ss->expr->ref;
2792 nDepend = gfc_dep_resolver (lref, rref);
2794 /* TODO : loop shifting. */
2797 /* Mark the dimensions for LOOP SHIFTING */
2798 for (n = 0; n < loop->dimen; n++)
2800 int dim = dest->data.info.dim[n];
2802 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2804 else if (! gfc_is_same_range (&lref->u.ar,
2805 &rref->u.ar, dim, 0))
2809 /* Put all the dimensions with dependencies in the
2812 for (n = 0; n < loop->dimen; n++)
2814 gcc_assert (loop->order[n] == n);
2816 loop->order[dim++] = n;
2819 for (n = 0; n < loop->dimen; n++)
2822 loop->order[dim++] = n;
2825 gcc_assert (dim == loop->dimen);
2834 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2835 if (GFC_ARRAY_TYPE_P (base_type)
2836 || GFC_DESCRIPTOR_TYPE_P (base_type))
2837 base_type = gfc_get_element_type (base_type);
2838 loop->temp_ss = gfc_get_ss ();
2839 loop->temp_ss->type = GFC_SS_TEMP;
2840 loop->temp_ss->data.temp.type = base_type;
2841 loop->temp_ss->string_length = dest->string_length;
2842 loop->temp_ss->data.temp.dimen = loop->dimen;
2843 loop->temp_ss->next = gfc_ss_terminator;
2844 gfc_add_ss_to_loop (loop, loop->temp_ss);
2847 loop->temp_ss = NULL;
2851 /* Initialize the scalarization loop. Creates the loop variables. Determines
2852 the range of the loop variables. Creates a temporary if required.
2853 Calculates how to transform from loop variables to array indices for each
2854 expression. Also generates code for scalar expressions which have been
2855 moved outside the loop. */
2858 gfc_conv_loop_setup (gfc_loopinfo * loop)
2863 gfc_ss_info *specinfo;
2867 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2868 bool dynamic[GFC_MAX_DIMENSIONS];
2874 for (n = 0; n < loop->dimen; n++)
2878 /* We use one SS term, and use that to determine the bounds of the
2879 loop for this dimension. We try to pick the simplest term. */
2880 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2884 /* The frontend has worked out the size for us. */
2889 if (ss->type == GFC_SS_CONSTRUCTOR)
2891 /* An unknown size constructor will always be rank one.
2892 Higher rank constructors will either have known shape,
2893 or still be wrapped in a call to reshape. */
2894 gcc_assert (loop->dimen == 1);
2896 /* Always prefer to use the constructor bounds if the size
2897 can be determined at compile time. Prefer not to otherwise,
2898 since the general case involves realloc, and it's better to
2899 avoid that overhead if possible. */
2900 c = ss->expr->value.constructor;
2901 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2902 if (!dynamic[n] || !loopspec[n])
2907 /* TODO: Pick the best bound if we have a choice between a
2908 function and something else. */
2909 if (ss->type == GFC_SS_FUNCTION)
2915 if (ss->type != GFC_SS_SECTION)
2919 specinfo = &loopspec[n]->data.info;
2922 info = &ss->data.info;
2926 /* Criteria for choosing a loop specifier (most important first):
2927 doesn't need realloc
2933 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2935 else if (integer_onep (info->stride[n])
2936 && !integer_onep (specinfo->stride[n]))
2938 else if (INTEGER_CST_P (info->stride[n])
2939 && !INTEGER_CST_P (specinfo->stride[n]))
2941 else if (INTEGER_CST_P (info->start[n])
2942 && !INTEGER_CST_P (specinfo->start[n]))
2944 /* We don't work out the upper bound.
2945 else if (INTEGER_CST_P (info->finish[n])
2946 && ! INTEGER_CST_P (specinfo->finish[n]))
2947 loopspec[n] = ss; */
2951 gfc_todo_error ("Unable to find scalarization loop specifier");
2953 info = &loopspec[n]->data.info;
2955 /* Set the extents of this range. */
2956 cshape = loopspec[n]->shape;
2957 if (cshape && INTEGER_CST_P (info->start[n])
2958 && INTEGER_CST_P (info->stride[n]))
2960 loop->from[n] = info->start[n];
2961 mpz_set (i, cshape[n]);
2962 mpz_sub_ui (i, i, 1);
2963 /* To = from + (size - 1) * stride. */
2964 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2965 if (!integer_onep (info->stride[n]))
2966 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2967 tmp, info->stride[n]);
2968 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2969 loop->from[n], tmp);
2973 loop->from[n] = info->start[n];
2974 switch (loopspec[n]->type)
2976 case GFC_SS_CONSTRUCTOR:
2977 /* The upper bound is calculated when we expand the
2979 gcc_assert (loop->to[n] == NULL_TREE);
2982 case GFC_SS_SECTION:
2983 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2987 case GFC_SS_FUNCTION:
2988 /* The loop bound will be set when we generate the call. */
2989 gcc_assert (loop->to[n] == NULL_TREE);
2997 /* Transform everything so we have a simple incrementing variable. */
2998 if (integer_onep (info->stride[n]))
2999 info->delta[n] = gfc_index_zero_node;
3002 /* Set the delta for this section. */
3003 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3004 /* Number of iterations is (end - start + step) / step.
3005 with start = 0, this simplifies to
3007 for (i = 0; i<=last; i++){...}; */
3008 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3009 loop->to[n], loop->from[n]);
3010 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
3011 tmp, info->stride[n]);
3012 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3013 /* Make the loop variable start at 0. */
3014 loop->from[n] = gfc_index_zero_node;
3018 /* Add all the scalar code that can be taken out of the loops.
3019 This may include calculating the loop bounds, so do it before
3020 allocating the temporary. */
3021 gfc_add_loop_ss_code (loop, loop->ss, false);
3023 /* If we want a temporary then create it. */
3024 if (loop->temp_ss != NULL)
3026 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3027 tmp = loop->temp_ss->data.temp.type;
3028 len = loop->temp_ss->string_length;
3029 n = loop->temp_ss->data.temp.dimen;
3030 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3031 loop->temp_ss->type = GFC_SS_SECTION;
3032 loop->temp_ss->data.info.dimen = n;
3033 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3034 &loop->temp_ss->data.info, tmp, false, true,
3038 for (n = 0; n < loop->temp_dim; n++)
3039 loopspec[loop->order[n]] = NULL;
3043 /* For array parameters we don't have loop variables, so don't calculate the
3045 if (loop->array_parameter)
3048 /* Calculate the translation from loop variables to array indices. */
3049 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3051 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
3054 info = &ss->data.info;
3056 for (n = 0; n < info->dimen; n++)
3060 /* If we are specifying the range the delta is already set. */
3061 if (loopspec[n] != ss)
3063 /* Calculate the offset relative to the loop variable.
3064 First multiply by the stride. */
3065 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3066 loop->from[n], info->stride[n]);
3068 /* Then subtract this from our starting value. */
3069 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3070 info->start[n], tmp);
3072 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3079 /* Fills in an array descriptor, and returns the size of the array. The size
3080 will be a simple_val, ie a variable or a constant. Also calculates the
3081 offset of the base. Returns the size of the array.
3085 for (n = 0; n < rank; n++)
3087 a.lbound[n] = specified_lower_bound;
3088 offset = offset + a.lbond[n] * stride;
3090 a.ubound[n] = specified_upper_bound;
3091 a.stride[n] = stride;
3092 size = ubound + size; //size = ubound + 1 - lbound
3093 stride = stride * size;
3100 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3101 gfc_expr ** lower, gfc_expr ** upper,
3102 stmtblock_t * pblock)
3114 stmtblock_t thenblock;
3115 stmtblock_t elseblock;
3120 type = TREE_TYPE (descriptor);
3122 stride = gfc_index_one_node;
3123 offset = gfc_index_zero_node;
3125 /* Set the dtype. */
3126 tmp = gfc_conv_descriptor_dtype (descriptor);
3127 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3129 or_expr = NULL_TREE;
3131 for (n = 0; n < rank; n++)
3133 /* We have 3 possibilities for determining the size of the array:
3134 lower == NULL => lbound = 1, ubound = upper[n]
3135 upper[n] = NULL => lbound = 1, ubound = lower[n]
3136 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3139 /* Set lower bound. */
3140 gfc_init_se (&se, NULL);
3142 se.expr = gfc_index_one_node;
3145 gcc_assert (lower[n]);
3148 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3149 gfc_add_block_to_block (pblock, &se.pre);
3153 se.expr = gfc_index_one_node;
3157 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3158 gfc_add_modify_expr (pblock, tmp, se.expr);
3160 /* Work out the offset for this component. */
3161 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3162 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3164 /* Start the calculation for the size of this dimension. */
3165 size = build2 (MINUS_EXPR, gfc_array_index_type,
3166 gfc_index_one_node, se.expr);
3168 /* Set upper bound. */
3169 gfc_init_se (&se, NULL);
3170 gcc_assert (ubound);
3171 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3172 gfc_add_block_to_block (pblock, &se.pre);
3174 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3175 gfc_add_modify_expr (pblock, tmp, se.expr);
3177 /* Store the stride. */
3178 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3179 gfc_add_modify_expr (pblock, tmp, stride);
3181 /* Calculate the size of this dimension. */
3182 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3184 /* Check wether the size for this dimension is negative. */
3185 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3186 gfc_index_zero_node);
3190 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3192 /* Multiply the stride by the number of elements in this dimension. */
3193 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3194 stride = gfc_evaluate_now (stride, pblock);
3197 /* The stride is the number of elements in the array, so multiply by the
3198 size of an element to get the total size. */
3199 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3200 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3202 if (poffset != NULL)
3204 offset = gfc_evaluate_now (offset, pblock);
3208 var = gfc_create_var (TREE_TYPE (size), "size");
3209 gfc_start_block (&thenblock);
3210 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3211 thencase = gfc_finish_block (&thenblock);
3213 gfc_start_block (&elseblock);
3214 gfc_add_modify_expr (&elseblock, var, size);
3215 elsecase = gfc_finish_block (&elseblock);
3217 tmp = gfc_evaluate_now (or_expr, pblock);
3218 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3219 gfc_add_expr_to_block (pblock, tmp);
3225 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3226 the work for an ALLOCATE statement. */
3230 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3240 int allocatable_array;
3241 int must_be_pointer;
3245 /* In Fortran 95, components can only contain pointers, so that,
3246 in ALLOCATE (foo%bar(2)), bar must be a pointer component.
3247 We test this by checking for ref->next.
3248 An implementation of TR 15581 would need to change this. */
3251 must_be_pointer = ref->next != NULL;
3253 must_be_pointer = 0;
3255 /* Find the last reference in the chain. */
3256 while (ref && ref->next != NULL)
3258 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3262 if (ref == NULL || ref->type != REF_ARRAY)
3265 /* Figure out the size of the array. */
3266 switch (ref->u.ar.type)
3270 upper = ref->u.ar.start;
3274 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3276 lower = ref->u.ar.as->lower;
3277 upper = ref->u.ar.as->upper;
3281 lower = ref->u.ar.start;
3282 upper = ref->u.ar.end;
3290 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3291 lower, upper, &se->pre);
3293 /* Allocate memory to store the data. */
3294 tmp = gfc_conv_descriptor_data_addr (se->expr);
3295 pointer = gfc_evaluate_now (tmp, &se->pre);
3297 if (must_be_pointer)
3298 allocatable_array = 0;
3300 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3302 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3304 if (allocatable_array)
3305 allocate = gfor_fndecl_allocate_array;
3307 allocate = gfor_fndecl_allocate;
3309 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3311 if (allocatable_array)
3312 allocate = gfor_fndecl_allocate64_array;
3314 allocate = gfor_fndecl_allocate64;
3319 tmp = gfc_chainon_list (NULL_TREE, pointer);
3320 tmp = gfc_chainon_list (tmp, size);
3321 tmp = gfc_chainon_list (tmp, pstat);
3322 tmp = build_function_call_expr (allocate, tmp);
3323 gfc_add_expr_to_block (&se->pre, tmp);
3325 tmp = gfc_conv_descriptor_offset (se->expr);
3326 gfc_add_modify_expr (&se->pre, tmp, offset);
3332 /* Deallocate an array variable. Also used when an allocated variable goes
3337 gfc_array_deallocate (tree descriptor, tree pstat)
3343 gfc_start_block (&block);
3344 /* Get a pointer to the data. */
3345 tmp = gfc_conv_descriptor_data_addr (descriptor);
3346 var = gfc_evaluate_now (tmp, &block);
3348 /* Parameter is the address of the data component. */
3349 tmp = gfc_chainon_list (NULL_TREE, var);
3350 tmp = gfc_chainon_list (tmp, pstat);
3351 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3352 gfc_add_expr_to_block (&block, tmp);
3354 return gfc_finish_block (&block);
3358 /* Create an array constructor from an initialization expression.
3359 We assume the frontend already did any expansions and conversions. */
3362 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3369 unsigned HOST_WIDE_INT lo;
3371 VEC(constructor_elt,gc) *v = NULL;
3373 switch (expr->expr_type)
3376 case EXPR_STRUCTURE:
3377 /* A single scalar or derived type value. Create an array with all
3378 elements equal to that value. */
3379 gfc_init_se (&se, NULL);
3381 if (expr->expr_type == EXPR_CONSTANT)
3382 gfc_conv_constant (&se, expr);
3384 gfc_conv_structure (&se, expr, 1);
3386 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3387 gcc_assert (tmp && INTEGER_CST_P (tmp));
3388 hi = TREE_INT_CST_HIGH (tmp);
3389 lo = TREE_INT_CST_LOW (tmp);
3393 /* This will probably eat buckets of memory for large arrays. */
3394 while (hi != 0 || lo != 0)
3396 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3404 /* Create a vector of all the elements. */
3405 for (c = expr->value.constructor; c; c = c->next)
3409 /* Problems occur when we get something like
3410 integer :: a(lots) = (/(i, i=1,lots)/) */
3411 /* TODO: Unexpanded array initializers. */
3413 ("Possible frontend bug: array constructor not expanded");
3415 if (mpz_cmp_si (c->n.offset, 0) != 0)
3416 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3420 if (mpz_cmp_si (c->repeat, 0) != 0)
3424 mpz_set (maxval, c->repeat);
3425 mpz_add (maxval, c->n.offset, maxval);
3426 mpz_sub_ui (maxval, maxval, 1);
3427 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3428 if (mpz_cmp_si (c->n.offset, 0) != 0)
3430 mpz_add_ui (maxval, c->n.offset, 1);
3431 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3434 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3436 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3442 gfc_init_se (&se, NULL);
3443 switch (c->expr->expr_type)
3446 gfc_conv_constant (&se, c->expr);
3447 if (range == NULL_TREE)
3448 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3451 if (index != NULL_TREE)
3452 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3453 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3457 case EXPR_STRUCTURE:
3458 gfc_conv_structure (&se, c->expr, 1);
3459 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3472 /* Create a constructor from the list of elements. */
3473 tmp = build_constructor (type, v);
3474 TREE_CONSTANT (tmp) = 1;
3475 TREE_INVARIANT (tmp) = 1;
3480 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3481 returns the size (in elements) of the array. */
3484 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3485 stmtblock_t * pblock)
3500 size = gfc_index_one_node;
3501 offset = gfc_index_zero_node;
3502 for (dim = 0; dim < as->rank; dim++)
3504 /* Evaluate non-constant array bound expressions. */
3505 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3506 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3508 gfc_init_se (&se, NULL);
3509 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3510 gfc_add_block_to_block (pblock, &se.pre);
3511 gfc_add_modify_expr (pblock, lbound, se.expr);
3513 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3514 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3516 gfc_init_se (&se, NULL);
3517 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3518 gfc_add_block_to_block (pblock, &se.pre);
3519 gfc_add_modify_expr (pblock, ubound, se.expr);
3521 /* The offset of this dimension. offset = offset - lbound * stride. */
3522 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3523 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3525 /* The size of this dimension, and the stride of the next. */
3526 if (dim + 1 < as->rank)
3527 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3529 stride = GFC_TYPE_ARRAY_SIZE (type);
3531 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3533 /* Calculate stride = size * (ubound + 1 - lbound). */
3534 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3535 gfc_index_one_node, lbound);
3536 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3537 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3539 gfc_add_modify_expr (pblock, stride, tmp);
3541 stride = gfc_evaluate_now (tmp, pblock);
3547 gfc_trans_vla_type_sizes (sym, pblock);
3554 /* Generate code to initialize/allocate an array variable. */
3557 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3567 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3569 /* Do nothing for USEd variables. */
3570 if (sym->attr.use_assoc)
3573 type = TREE_TYPE (decl);
3574 gcc_assert (GFC_ARRAY_TYPE_P (type));
3575 onstack = TREE_CODE (type) != POINTER_TYPE;
3577 gfc_start_block (&block);
3579 /* Evaluate character string length. */
3580 if (sym->ts.type == BT_CHARACTER
3581 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3583 gfc_trans_init_string_length (sym->ts.cl, &block);
3585 gfc_trans_vla_type_sizes (sym, &block);
3587 /* Emit a DECL_EXPR for this variable, which will cause the
3588 gimplifier to allocate storage, and all that good stuff. */
3589 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3590 gfc_add_expr_to_block (&block, tmp);
3595 gfc_add_expr_to_block (&block, fnbody);
3596 return gfc_finish_block (&block);
3599 type = TREE_TYPE (type);
3601 gcc_assert (!sym->attr.use_assoc);
3602 gcc_assert (!TREE_STATIC (decl));
3603 gcc_assert (!sym->module);
3605 if (sym->ts.type == BT_CHARACTER
3606 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3607 gfc_trans_init_string_length (sym->ts.cl, &block);
3609 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3611 /* Don't actually allocate space for Cray Pointees. */
3612 if (sym->attr.cray_pointee)
3614 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3615 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3616 gfc_add_expr_to_block (&block, fnbody);
3617 return gfc_finish_block (&block);
3620 /* The size is the number of elements in the array, so multiply by the
3621 size of an element to get the total size. */
3622 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3623 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3625 /* Allocate memory to hold the data. */
3626 tmp = gfc_chainon_list (NULL_TREE, size);
3628 if (gfc_index_integer_kind == 4)
3629 fndecl = gfor_fndecl_internal_malloc;
3630 else if (gfc_index_integer_kind == 8)
3631 fndecl = gfor_fndecl_internal_malloc64;
3634 tmp = build_function_call_expr (fndecl, tmp);
3635 tmp = fold (convert (TREE_TYPE (decl), tmp));
3636 gfc_add_modify_expr (&block, decl, tmp);
3638 /* Set offset of the array. */
3639 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3640 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3643 /* Automatic arrays should not have initializers. */
3644 gcc_assert (!sym->value);
3646 gfc_add_expr_to_block (&block, fnbody);
3648 /* Free the temporary. */
3649 tmp = convert (pvoid_type_node, decl);
3650 tmp = gfc_chainon_list (NULL_TREE, tmp);
3651 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3652 gfc_add_expr_to_block (&block, tmp);
3654 return gfc_finish_block (&block);
3658 /* Generate entry and exit code for g77 calling convention arrays. */
3661 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3670 gfc_get_backend_locus (&loc);
3671 gfc_set_backend_locus (&sym->declared_at);
3673 /* Descriptor type. */
3674 parm = sym->backend_decl;
3675 type = TREE_TYPE (parm);
3676 gcc_assert (GFC_ARRAY_TYPE_P (type));
3678 gfc_start_block (&block);
3680 if (sym->ts.type == BT_CHARACTER
3681 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3682 gfc_trans_init_string_length (sym->ts.cl, &block);
3684 /* Evaluate the bounds of the array. */
3685 gfc_trans_array_bounds (type, sym, &offset, &block);
3687 /* Set the offset. */
3688 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3689 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3691 /* Set the pointer itself if we aren't using the parameter directly. */
3692 if (TREE_CODE (parm) != PARM_DECL)
3694 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3695 gfc_add_modify_expr (&block, parm, tmp);
3697 tmp = gfc_finish_block (&block);
3699 gfc_set_backend_locus (&loc);
3701 gfc_start_block (&block);
3702 /* Add the initialization code to the start of the function. */
3703 gfc_add_expr_to_block (&block, tmp);
3704 gfc_add_expr_to_block (&block, body);
3706 return gfc_finish_block (&block);
3710 /* Modify the descriptor of an array parameter so that it has the
3711 correct lower bound. Also move the upper bound accordingly.
3712 If the array is not packed, it will be copied into a temporary.
3713 For each dimension we set the new lower and upper bounds. Then we copy the
3714 stride and calculate the offset for this dimension. We also work out
3715 what the stride of a packed array would be, and see it the two match.
3716 If the array need repacking, we set the stride to the values we just
3717 calculated, recalculate the offset and copy the array data.
3718 Code is also added to copy the data back at the end of the function.
3722 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3729 stmtblock_t cleanup;
3737 tree stride, stride2;
3747 /* Do nothing for pointer and allocatable arrays. */
3748 if (sym->attr.pointer || sym->attr.allocatable)
3751 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3752 return gfc_trans_g77_array (sym, body);
3754 gfc_get_backend_locus (&loc);
3755 gfc_set_backend_locus (&sym->declared_at);
3757 /* Descriptor type. */
3758 type = TREE_TYPE (tmpdesc);
3759 gcc_assert (GFC_ARRAY_TYPE_P (type));
3760 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3761 dumdesc = build_fold_indirect_ref (dumdesc);
3762 gfc_start_block (&block);
3764 if (sym->ts.type == BT_CHARACTER
3765 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3766 gfc_trans_init_string_length (sym->ts.cl, &block);
3768 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3770 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3771 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3773 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3775 /* For non-constant shape arrays we only check if the first dimension
3776 is contiguous. Repacking higher dimensions wouldn't gain us
3777 anything as we still don't know the array stride. */
3778 partial = gfc_create_var (boolean_type_node, "partial");
3779 TREE_USED (partial) = 1;
3780 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3781 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
3782 gfc_add_modify_expr (&block, partial, tmp);
3786 partial = NULL_TREE;
3789 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3790 here, however I think it does the right thing. */
3793 /* Set the first stride. */
3794 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3795 stride = gfc_evaluate_now (stride, &block);
3797 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
3798 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3799 gfc_index_one_node, stride);
3800 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3801 gfc_add_modify_expr (&block, stride, tmp);
3803 /* Allow the user to disable array repacking. */
3804 stmt_unpacked = NULL_TREE;
3808 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3809 /* A library call to repack the array if necessary. */
3810 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3811 tmp = gfc_chainon_list (NULL_TREE, tmp);
3812 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3814 stride = gfc_index_one_node;
3817 /* This is for the case where the array data is used directly without
3818 calling the repack function. */
3819 if (no_repack || partial != NULL_TREE)
3820 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3822 stmt_packed = NULL_TREE;
3824 /* Assign the data pointer. */
3825 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3827 /* Don't repack unknown shape arrays when the first stride is 1. */
3828 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3829 stmt_packed, stmt_unpacked);
3832 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3833 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3835 offset = gfc_index_zero_node;
3836 size = gfc_index_one_node;
3838 /* Evaluate the bounds of the array. */
3839 for (n = 0; n < sym->as->rank; n++)
3841 if (checkparm || !sym->as->upper[n])
3843 /* Get the bounds of the actual parameter. */
3844 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3845 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3849 dubound = NULL_TREE;
3850 dlbound = NULL_TREE;
3853 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3854 if (!INTEGER_CST_P (lbound))
3856 gfc_init_se (&se, NULL);
3857 gfc_conv_expr_type (&se, sym->as->lower[n],
3858 gfc_array_index_type);
3859 gfc_add_block_to_block (&block, &se.pre);
3860 gfc_add_modify_expr (&block, lbound, se.expr);
3863 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3864 /* Set the desired upper bound. */
3865 if (sym->as->upper[n])
3867 /* We know what we want the upper bound to be. */
3868 if (!INTEGER_CST_P (ubound))
3870 gfc_init_se (&se, NULL);
3871 gfc_conv_expr_type (&se, sym->as->upper[n],
3872 gfc_array_index_type);
3873 gfc_add_block_to_block (&block, &se.pre);
3874 gfc_add_modify_expr (&block, ubound, se.expr);
3877 /* Check the sizes match. */
3880 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3883 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3885 stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
3887 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
3888 asprintf (&msg, "%s for dimension %d of array '%s'",
3889 gfc_msg_bounds, n+1, sym->name);
3890 gfc_trans_runtime_check (tmp, msg, &block, NULL);
3896 /* For assumed shape arrays move the upper bound by the same amount
3897 as the lower bound. */
3898 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3899 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3900 gfc_add_modify_expr (&block, ubound, tmp);
3902 /* The offset of this dimension. offset = offset - lbound * stride. */
3903 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3904 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3906 /* The size of this dimension, and the stride of the next. */
3907 if (n + 1 < sym->as->rank)
3909 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3911 if (no_repack || partial != NULL_TREE)
3914 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3917 /* Figure out the stride if not a known constant. */
3918 if (!INTEGER_CST_P (stride))
3921 stmt_packed = NULL_TREE;
3924 /* Calculate stride = size * (ubound + 1 - lbound). */
3925 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3926 gfc_index_one_node, lbound);
3927 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3929 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3934 /* Assign the stride. */
3935 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3936 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3937 stmt_unpacked, stmt_packed);
3939 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3940 gfc_add_modify_expr (&block, stride, tmp);
3945 stride = GFC_TYPE_ARRAY_SIZE (type);
3947 if (stride && !INTEGER_CST_P (stride))
3949 /* Calculate size = stride * (ubound + 1 - lbound). */
3950 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3951 gfc_index_one_node, lbound);
3952 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3954 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3955 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
3956 gfc_add_modify_expr (&block, stride, tmp);
3961 /* Set the offset. */
3962 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3963 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3965 gfc_trans_vla_type_sizes (sym, &block);
3967 stmt = gfc_finish_block (&block);
3969 gfc_start_block (&block);
3971 /* Only do the entry/initialization code if the arg is present. */
3972 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3973 optional_arg = (sym->attr.optional
3974 || (sym->ns->proc_name->attr.entry_master
3975 && sym->attr.dummy));
3978 tmp = gfc_conv_expr_present (sym);
3979 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3981 gfc_add_expr_to_block (&block, stmt);
3983 /* Add the main function body. */
3984 gfc_add_expr_to_block (&block, body);
3989 gfc_start_block (&cleanup);
3991 if (sym->attr.intent != INTENT_IN)
3993 /* Copy the data back. */
3994 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3995 tmp = gfc_chainon_list (tmp, tmpdesc);
3996 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3997 gfc_add_expr_to_block (&cleanup, tmp);
4000 /* Free the temporary. */
4001 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
4002 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4003 gfc_add_expr_to_block (&cleanup, tmp);
4005 stmt = gfc_finish_block (&cleanup);
4007 /* Only do the cleanup if the array was repacked. */
4008 tmp = build_fold_indirect_ref (dumdesc);
4009 tmp = gfc_conv_descriptor_data_get (tmp);
4010 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4011 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4015 tmp = gfc_conv_expr_present (sym);
4016 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4018 gfc_add_expr_to_block (&block, stmt);
4020 /* We don't need to free any memory allocated by internal_pack as it will
4021 be freed at the end of the function by pop_context. */
4022 return gfc_finish_block (&block);
4026 /* Convert an array for passing as an actual argument. Expressions and
4027 vector subscripts are evaluated and stored in a temporary, which is then
4028 passed. For whole arrays the descriptor is passed. For array sections
4029 a modified copy of the descriptor is passed, but using the original data.
4031 This function is also used for array pointer assignments, and there
4034 - want_pointer && !se->direct_byref
4035 EXPR is an actual argument. On exit, se->expr contains a
4036 pointer to the array descriptor.
4038 - !want_pointer && !se->direct_byref
4039 EXPR is an actual argument to an intrinsic function or the
4040 left-hand side of a pointer assignment. On exit, se->expr
4041 contains the descriptor for EXPR.
4043 - !want_pointer && se->direct_byref
4044 EXPR is the right-hand side of a pointer assignment and
4045 se->expr is the descriptor for the previously-evaluated
4046 left-hand side. The function creates an assignment from
4047 EXPR to se->expr. */
4050 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4065 gcc_assert (ss != gfc_ss_terminator);
4067 /* TODO: Pass constant array constructors without a temporary. */
4068 /* Special case things we know we can pass easily. */
4069 switch (expr->expr_type)
4072 /* If we have a linear array section, we can pass it directly.
4073 Otherwise we need to copy it into a temporary. */
4075 /* Find the SS for the array section. */
4077 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4078 secss = secss->next;
4080 gcc_assert (secss != gfc_ss_terminator);
4081 info = &secss->data.info;
4083 /* Get the descriptor for the array. */
4084 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4085 desc = info->descriptor;
4087 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
4090 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4092 /* Create a new descriptor if the array doesn't have one. */
4095 else if (info->ref->u.ar.type == AR_FULL)
4097 else if (se->direct_byref)
4102 gcc_assert (ref->u.ar.type == AR_SECTION);
4105 for (n = 0; n < ref->u.ar.dimen; n++)
4107 /* Detect passing the full array as a section. This could do
4108 even more checking, but it doesn't seem worth it. */
4109 if (ref->u.ar.start[n]
4111 || (ref->u.ar.stride[n]
4112 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
4122 if (se->direct_byref)
4124 /* Copy the descriptor for pointer assignments. */
4125 gfc_add_modify_expr (&se->pre, se->expr, desc);
4127 else if (se->want_pointer)
4129 /* We pass full arrays directly. This means that pointers and
4130 allocatable arrays should also work. */
4131 se->expr = build_fold_addr_expr (desc);
4138 if (expr->ts.type == BT_CHARACTER)
4139 se->string_length = gfc_get_expr_charlen (expr);
4146 /* A transformational function return value will be a temporary
4147 array descriptor. We still need to go through the scalarizer
4148 to create the descriptor. Elemental functions ar handled as
4149 arbitrary expressions, i.e. copy to a temporary. */
4151 /* Look for the SS for this function. */
4152 while (secss != gfc_ss_terminator
4153 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4154 secss = secss->next;
4156 if (se->direct_byref)
4158 gcc_assert (secss != gfc_ss_terminator);
4160 /* For pointer assignments pass the descriptor directly. */
4162 se->expr = build_fold_addr_expr (se->expr);
4163 gfc_conv_expr (se, expr);
4167 if (secss == gfc_ss_terminator)
4169 /* Elemental function. */
4175 /* Transformational function. */
4176 info = &secss->data.info;
4182 /* Something complicated. Copy it into a temporary. */
4190 gfc_init_loopinfo (&loop);
4192 /* Associate the SS with the loop. */
4193 gfc_add_ss_to_loop (&loop, ss);
4195 /* Tell the scalarizer not to bother creating loop variables, etc. */
4197 loop.array_parameter = 1;
4199 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4200 gcc_assert (!se->direct_byref);
4202 /* Setup the scalarizing loops and bounds. */
4203 gfc_conv_ss_startstride (&loop);
4207 /* Tell the scalarizer to make a temporary. */
4208 loop.temp_ss = gfc_get_ss ();
4209 loop.temp_ss->type = GFC_SS_TEMP;
4210 loop.temp_ss->next = gfc_ss_terminator;
4211 if (expr->ts.type == BT_CHARACTER)
4213 if (expr->ts.cl == NULL)
4215 /* This had better be a substring reference! */
4216 gfc_ref *char_ref = expr->ref;
4217 for (; char_ref; char_ref = char_ref->next)
4218 if (char_ref->type == REF_SUBSTRING)
4221 expr->ts.cl = gfc_get_charlen ();
4222 expr->ts.cl->next = char_ref->u.ss.length->next;
4223 char_ref->u.ss.length->next = expr->ts.cl;
4225 mpz_init_set_ui (char_len, 1);
4226 mpz_add (char_len, char_len,
4227 char_ref->u.ss.end->value.integer);
4228 mpz_sub (char_len, char_len,
4229 char_ref->u.ss.start->value.integer);
4230 expr->ts.cl->backend_decl
4231 = gfc_conv_mpz_to_tree (char_len,
4232 gfc_default_character_kind);
4233 /* Cast is necessary for *-charlen refs. */
4234 expr->ts.cl->backend_decl
4235 = convert (gfc_charlen_type_node,
4236 expr->ts.cl->backend_decl);
4237 mpz_clear (char_len);
4240 gcc_assert (char_ref != NULL);
4241 loop.temp_ss->data.temp.type
4242 = gfc_typenode_for_spec (&expr->ts);
4243 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4245 else if (expr->ts.cl->length
4246 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4248 expr->ts.cl->backend_decl
4249 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4250 expr->ts.cl->length->ts.kind);
4251 loop.temp_ss->data.temp.type
4252 = gfc_typenode_for_spec (&expr->ts);
4253 loop.temp_ss->string_length
4254 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4258 loop.temp_ss->data.temp.type
4259 = gfc_typenode_for_spec (&expr->ts);
4260 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4262 se->string_length = loop.temp_ss->string_length;
4266 loop.temp_ss->data.temp.type
4267 = gfc_typenode_for_spec (&expr->ts);
4268 loop.temp_ss->string_length = NULL;
4270 loop.temp_ss->data.temp.dimen = loop.dimen;
4271 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4274 gfc_conv_loop_setup (&loop);
4278 /* Copy into a temporary and pass that. We don't need to copy the data
4279 back because expressions and vector subscripts must be INTENT_IN. */
4280 /* TODO: Optimize passing function return values. */
4284 /* Start the copying loops. */
4285 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4286 gfc_mark_ss_chain_used (ss, 1);
4287 gfc_start_scalarized_body (&loop, &block);
4289 /* Copy each data element. */
4290 gfc_init_se (&lse, NULL);
4291 gfc_copy_loopinfo_to_se (&lse, &loop);
4292 gfc_init_se (&rse, NULL);
4293 gfc_copy_loopinfo_to_se (&rse, &loop);
4295 lse.ss = loop.temp_ss;
4298 gfc_conv_scalarized_array_ref (&lse, NULL);
4299 if (expr->ts.type == BT_CHARACTER)
4301 gfc_conv_expr (&rse, expr);
4302 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4303 rse.expr = build_fold_indirect_ref (rse.expr);
4306 gfc_conv_expr_val (&rse, expr);
4308 gfc_add_block_to_block (&block, &rse.pre);
4309 gfc_add_block_to_block (&block, &lse.pre);
4311 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4313 /* Finish the copying loops. */
4314 gfc_trans_scalarizing_loops (&loop, &block);
4316 desc = loop.temp_ss->data.info.descriptor;
4318 gcc_assert (is_gimple_lvalue (desc));
4320 else if (expr->expr_type == EXPR_FUNCTION)
4322 desc = info->descriptor;
4323 se->string_length = ss->string_length;
4327 /* We pass sections without copying to a temporary. Make a new
4328 descriptor and point it at the section we want. The loop variable
4329 limits will be the limits of the section.
4330 A function may decide to repack the array to speed up access, but
4331 we're not bothered about that here. */
4340 /* Set the string_length for a character array. */
4341 if (expr->ts.type == BT_CHARACTER)
4342 se->string_length = gfc_get_expr_charlen (expr);
4344 desc = info->descriptor;
4345 gcc_assert (secss && secss != gfc_ss_terminator);
4346 if (se->direct_byref)
4348 /* For pointer assignments we fill in the destination. */
4350 parmtype = TREE_TYPE (parm);
4354 /* Otherwise make a new one. */
4355 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4356 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4357 loop.from, loop.to, 0);
4358 parm = gfc_create_var (parmtype, "parm");
4361 offset = gfc_index_zero_node;
4364 /* The following can be somewhat confusing. We have two
4365 descriptors, a new one and the original array.
4366 {parm, parmtype, dim} refer to the new one.
4367 {desc, type, n, secss, loop} refer to the original, which maybe
4368 a descriptorless array.
4369 The bounds of the scalarization are the bounds of the section.
4370 We don't have to worry about numeric overflows when calculating
4371 the offsets because all elements are within the array data. */
4373 /* Set the dtype. */
4374 tmp = gfc_conv_descriptor_dtype (parm);
4375 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4377 if (se->direct_byref)
4378 base = gfc_index_zero_node;
4382 for (n = 0; n < info->ref->u.ar.dimen; n++)
4384 stride = gfc_conv_array_stride (desc, n);
4386 /* Work out the offset. */
4387 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4389 gcc_assert (info->subscript[n]
4390 && info->subscript[n]->type == GFC_SS_SCALAR);
4391 start = info->subscript[n]->data.scalar.expr;
4395 /* Check we haven't somehow got out of sync. */
4396 gcc_assert (info->dim[dim] == n);
4398 /* Evaluate and remember the start of the section. */
4399 start = info->start[dim];
4400 stride = gfc_evaluate_now (stride, &loop.pre);
4403 tmp = gfc_conv_array_lbound (desc, n);
4404 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4406 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4407 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4409 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4411 /* For elemental dimensions, we only need the offset. */
4415 /* Vector subscripts need copying and are handled elsewhere. */
4416 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4418 /* Set the new lower bound. */
4419 from = loop.from[dim];
4422 /* If we have an array section or are assigning to a pointer,
4423 make sure that the lower bound is 1. References to the full
4424 array should otherwise keep the original bounds. */
4425 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4426 && !integer_onep (from))
4428 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4429 gfc_index_one_node, from);
4430 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4431 from = gfc_index_one_node;
4433 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4434 gfc_add_modify_expr (&loop.pre, tmp, from);
4436 /* Set the new upper bound. */
4437 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4438 gfc_add_modify_expr (&loop.pre, tmp, to);
4440 /* Multiply the stride by the section stride to get the
4442 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4443 stride, info->stride[dim]);
4445 if (se->direct_byref)
4446 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4449 /* Store the new stride. */
4450 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4451 gfc_add_modify_expr (&loop.pre, tmp, stride);
4456 if (se->data_not_needed)
4457 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4460 /* Point the data pointer at the first element in the section. */
4461 tmp = gfc_conv_array_data (desc);
4462 tmp = build_fold_indirect_ref (tmp);
4463 tmp = gfc_build_array_ref (tmp, offset);
4464 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4465 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4468 if (se->direct_byref && !se->data_not_needed)
4470 /* Set the offset. */
4471 tmp = gfc_conv_descriptor_offset (parm);
4472 gfc_add_modify_expr (&loop.pre, tmp, base);
4476 /* Only the callee knows what the correct offset it, so just set
4478 tmp = gfc_conv_descriptor_offset (parm);
4479 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4484 if (!se->direct_byref)
4486 /* Get a pointer to the new descriptor. */
4487 if (se->want_pointer)
4488 se->expr = build_fold_addr_expr (desc);
4493 gfc_add_block_to_block (&se->pre, &loop.pre);
4494 gfc_add_block_to_block (&se->post, &loop.post);
4496 /* Cleanup the scalarizer. */
4497 gfc_cleanup_loop (&loop);
4501 /* Convert an array for passing as an actual parameter. */
4502 /* TODO: Optimize passing g77 arrays. */
4505 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4514 /* Passing address of the array if it is not pointer or assumed-shape. */
4515 if (expr->expr_type == EXPR_VARIABLE
4516 && expr->ref->u.ar.type == AR_FULL && g77)
4518 sym = expr->symtree->n.sym;
4519 tmp = gfc_get_symbol_decl (sym);
4521 if (sym->ts.type == BT_CHARACTER)
4522 se->string_length = sym->ts.cl->backend_decl;
4523 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4524 && !sym->attr.allocatable)
4526 /* Some variables are declared directly, others are declared as
4527 pointers and allocated on the heap. */
4528 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4531 se->expr = build_fold_addr_expr (tmp);
4534 if (sym->attr.allocatable)
4536 if (sym->attr.dummy)
4538 gfc_conv_expr_descriptor (se, expr, ss);
4539 se->expr = gfc_conv_array_data (se->expr);
4542 se->expr = gfc_conv_array_data (tmp);
4547 se->want_pointer = 1;
4548 gfc_conv_expr_descriptor (se, expr, ss);
4553 /* Repack the array. */
4554 tmp = gfc_chainon_list (NULL_TREE, desc);
4555 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4556 ptr = gfc_evaluate_now (ptr, &se->pre);
4559 gfc_start_block (&block);
4561 /* Copy the data back. */
4562 tmp = gfc_chainon_list (NULL_TREE, desc);
4563 tmp = gfc_chainon_list (tmp, ptr);
4564 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4565 gfc_add_expr_to_block (&block, tmp);
4567 /* Free the temporary. */
4568 tmp = convert (pvoid_type_node, ptr);
4569 tmp = gfc_chainon_list (NULL_TREE, tmp);
4570 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4571 gfc_add_expr_to_block (&block, tmp);
4573 stmt = gfc_finish_block (&block);
4575 gfc_init_block (&block);
4576 /* Only if it was repacked. This code needs to be executed before the
4577 loop cleanup code. */
4578 tmp = build_fold_indirect_ref (desc);
4579 tmp = gfc_conv_array_data (tmp);
4580 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4581 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4583 gfc_add_expr_to_block (&block, tmp);
4584 gfc_add_block_to_block (&block, &se->post);
4586 gfc_init_block (&se->post);
4587 gfc_add_block_to_block (&se->post, &block);
4592 /* Generate code to deallocate an array, if it is allocated. */
4595 gfc_trans_dealloc_allocated (tree descriptor)
4601 gfc_start_block (&block);
4602 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4604 tmp = gfc_conv_descriptor_data_get (descriptor);
4605 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4606 build_int_cst (TREE_TYPE (tmp), 0));
4607 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4608 gfc_add_expr_to_block (&block, tmp);
4610 tmp = gfc_finish_block (&block);
4616 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4619 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4624 stmtblock_t fnblock;
4627 /* Make sure the frontend gets these right. */
4628 if (!(sym->attr.pointer || sym->attr.allocatable))
4630 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4632 gfc_init_block (&fnblock);
4634 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4635 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4637 if (sym->ts.type == BT_CHARACTER
4638 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4640 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4641 gfc_trans_vla_type_sizes (sym, &fnblock);
4644 /* Dummy and use associated variables don't need anything special. */
4645 if (sym->attr.dummy || sym->attr.use_assoc)
4647 gfc_add_expr_to_block (&fnblock, body);
4649 return gfc_finish_block (&fnblock);
4652 gfc_get_backend_locus (&loc);
4653 gfc_set_backend_locus (&sym->declared_at);
4654 descriptor = sym->backend_decl;
4656 if (TREE_STATIC (descriptor))
4658 /* SAVEd variables are not freed on exit. */
4659 gfc_trans_static_array_pointer (sym);
4663 /* Get the descriptor type. */
4664 type = TREE_TYPE (sym->backend_decl);
4665 if (!GFC_DESCRIPTOR_TYPE_P (type))
4667 /* If the backend_decl is not a descriptor, we must have a pointer
4669 descriptor = build_fold_indirect_ref (sym->backend_decl);
4670 type = TREE_TYPE (descriptor);
4671 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4674 /* NULLIFY the data pointer. */
4675 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4677 gfc_add_expr_to_block (&fnblock, body);
4679 gfc_set_backend_locus (&loc);
4680 /* Allocatable arrays need to be freed when they go out of scope. */
4681 if (sym->attr.allocatable)
4683 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4684 gfc_add_expr_to_block (&fnblock, tmp);
4687 return gfc_finish_block (&fnblock);
4690 /************ Expression Walking Functions ******************/
4692 /* Walk a variable reference.
4694 Possible extension - multiple component subscripts.
4695 x(:,:) = foo%a(:)%b(:)
4697 forall (i=..., j=...)
4698 x(i,j) = foo%a(j)%b(i)
4700 This adds a fair amout of complexity because you need to deal with more
4701 than one ref. Maybe handle in a similar manner to vector subscripts.
4702 Maybe not worth the effort. */
4706 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4714 for (ref = expr->ref; ref; ref = ref->next)
4715 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4718 for (; ref; ref = ref->next)
4720 if (ref->type == REF_SUBSTRING)
4722 newss = gfc_get_ss ();
4723 newss->type = GFC_SS_SCALAR;
4724 newss->expr = ref->u.ss.start;
4728 newss = gfc_get_ss ();
4729 newss->type = GFC_SS_SCALAR;
4730 newss->expr = ref->u.ss.end;
4735 /* We're only interested in array sections from now on. */
4736 if (ref->type != REF_ARRAY)
4743 for (n = 0; n < ar->dimen; n++)
4745 newss = gfc_get_ss ();
4746 newss->type = GFC_SS_SCALAR;
4747 newss->expr = ar->start[n];
4754 newss = gfc_get_ss ();
4755 newss->type = GFC_SS_SECTION;
4758 newss->data.info.dimen = ar->as->rank;
4759 newss->data.info.ref = ref;
4761 /* Make sure array is the same as array(:,:), this way
4762 we don't need to special case all the time. */
4763 ar->dimen = ar->as->rank;
4764 for (n = 0; n < ar->dimen; n++)
4766 newss->data.info.dim[n] = n;
4767 ar->dimen_type[n] = DIMEN_RANGE;
4769 gcc_assert (ar->start[n] == NULL);
4770 gcc_assert (ar->end[n] == NULL);
4771 gcc_assert (ar->stride[n] == NULL);
4777 newss = gfc_get_ss ();
4778 newss->type = GFC_SS_SECTION;
4781 newss->data.info.dimen = 0;
4782 newss->data.info.ref = ref;
4786 /* We add SS chains for all the subscripts in the section. */
4787 for (n = 0; n < ar->dimen; n++)
4791 switch (ar->dimen_type[n])
4794 /* Add SS for elemental (scalar) subscripts. */
4795 gcc_assert (ar->start[n]);
4796 indexss = gfc_get_ss ();
4797 indexss->type = GFC_SS_SCALAR;
4798 indexss->expr = ar->start[n];
4799 indexss->next = gfc_ss_terminator;
4800 indexss->loop_chain = gfc_ss_terminator;
4801 newss->data.info.subscript[n] = indexss;
4805 /* We don't add anything for sections, just remember this
4806 dimension for later. */
4807 newss->data.info.dim[newss->data.info.dimen] = n;
4808 newss->data.info.dimen++;
4812 /* Create a GFC_SS_VECTOR index in which we can store
4813 the vector's descriptor. */
4814 indexss = gfc_get_ss ();
4815 indexss->type = GFC_SS_VECTOR;
4816 indexss->expr = ar->start[n];
4817 indexss->next = gfc_ss_terminator;
4818 indexss->loop_chain = gfc_ss_terminator;
4819 newss->data.info.subscript[n] = indexss;
4820 newss->data.info.dim[newss->data.info.dimen] = n;
4821 newss->data.info.dimen++;
4825 /* We should know what sort of section it is by now. */
4829 /* We should have at least one non-elemental dimension. */
4830 gcc_assert (newss->data.info.dimen > 0);
4835 /* We should know what sort of section it is by now. */
4844 /* Walk an expression operator. If only one operand of a binary expression is
4845 scalar, we must also add the scalar term to the SS chain. */
4848 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4854 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4855 if (expr->value.op.op2 == NULL)
4858 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4860 /* All operands are scalar. Pass back and let the caller deal with it. */
4864 /* All operands require scalarization. */
4865 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4868 /* One of the operands needs scalarization, the other is scalar.
4869 Create a gfc_ss for the scalar expression. */
4870 newss = gfc_get_ss ();
4871 newss->type = GFC_SS_SCALAR;
4874 /* First operand is scalar. We build the chain in reverse order, so
4875 add the scarar SS after the second operand. */
4877 while (head && head->next != ss)
4879 /* Check we haven't somehow broken the chain. */
4883 newss->expr = expr->value.op.op1;
4885 else /* head2 == head */
4887 gcc_assert (head2 == head);
4888 /* Second operand is scalar. */
4889 newss->next = head2;
4891 newss->expr = expr->value.op.op2;
4898 /* Reverse a SS chain. */
4901 gfc_reverse_ss (gfc_ss * ss)
4906 gcc_assert (ss != NULL);
4908 head = gfc_ss_terminator;
4909 while (ss != gfc_ss_terminator)
4912 /* Check we didn't somehow break the chain. */
4913 gcc_assert (next != NULL);
4923 /* Walk the arguments of an elemental function. */
4926 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4934 head = gfc_ss_terminator;
4937 for (; arg; arg = arg->next)
4942 newss = gfc_walk_subexpr (head, arg->expr);
4945 /* Scalar argument. */
4946 newss = gfc_get_ss ();
4948 newss->expr = arg->expr;
4958 while (tail->next != gfc_ss_terminator)
4965 /* If all the arguments are scalar we don't need the argument SS. */
4966 gfc_free_ss_chain (head);
4971 /* Add it onto the existing chain. */
4977 /* Walk a function call. Scalar functions are passed back, and taken out of
4978 scalarization loops. For elemental functions we walk their arguments.
4979 The result of functions returning arrays is stored in a temporary outside
4980 the loop, so that the function is only called once. Hence we do not need
4981 to walk their arguments. */
4984 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4987 gfc_intrinsic_sym *isym;
4990 isym = expr->value.function.isym;
4992 /* Handle intrinsic functions separately. */
4994 return gfc_walk_intrinsic_function (ss, expr, isym);
4996 sym = expr->value.function.esym;
4998 sym = expr->symtree->n.sym;
5000 /* A function that returns arrays. */
5001 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
5003 newss = gfc_get_ss ();
5004 newss->type = GFC_SS_FUNCTION;
5007 newss->data.info.dimen = expr->rank;
5011 /* Walk the parameters of an elemental function. For now we always pass
5013 if (sym->attr.elemental)
5014 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
5017 /* Scalar functions are OK as these are evaluated outside the scalarization
5018 loop. Pass back and let the caller deal with it. */
5023 /* An array temporary is constructed for array constructors. */
5026 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
5031 newss = gfc_get_ss ();
5032 newss->type = GFC_SS_CONSTRUCTOR;
5035 newss->data.info.dimen = expr->rank;
5036 for (n = 0; n < expr->rank; n++)
5037 newss->data.info.dim[n] = n;
5043 /* Walk an expression. Add walked expressions to the head of the SS chain.
5044 A wholly scalar expression will not be added. */
5047 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
5051 switch (expr->expr_type)
5054 head = gfc_walk_variable_expr (ss, expr);
5058 head = gfc_walk_op_expr (ss, expr);
5062 head = gfc_walk_function_expr (ss, expr);
5067 case EXPR_STRUCTURE:
5068 /* Pass back and let the caller deal with it. */
5072 head = gfc_walk_array_constructor (ss, expr);
5075 case EXPR_SUBSTRING:
5076 /* Pass back and let the caller deal with it. */
5080 internal_error ("bad expression type during walk (%d)",
5087 /* Entry point for expression walking.
5088 A return value equal to the passed chain means this is
5089 a scalar expression. It is up to the caller to take whatever action is
5090 necessary to translate these. */
5093 gfc_walk_expr (gfc_expr * expr)
5097 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
5098 return gfc_reverse_ss (res);