1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
171 type = TREE_TYPE (desc);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174 field = TYPE_FIELDS (type);
175 gcc_assert (DATA_FIELD == 0);
177 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc)
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
197 return gfc_build_addr_expr (NULL_TREE, t);
201 gfc_conv_descriptor_offset (tree desc)
206 type = TREE_TYPE (desc);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
210 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_offset_get (tree desc)
219 return gfc_conv_descriptor_offset (desc);
223 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
226 tree t = gfc_conv_descriptor_offset (desc);
227 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
232 gfc_conv_descriptor_dtype (tree desc)
237 type = TREE_TYPE (desc);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
241 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
243 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
244 desc, field, NULL_TREE);
248 gfc_conv_descriptor_dimension (tree desc, tree dim)
254 type = TREE_TYPE (desc);
255 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
257 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
258 gcc_assert (field != NULL_TREE
259 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
260 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
262 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
263 desc, field, NULL_TREE);
264 tmp = gfc_build_array_ref (tmp, dim, NULL);
269 gfc_conv_descriptor_stride (tree desc, tree dim)
274 tmp = gfc_conv_descriptor_dimension (desc, dim);
275 field = TYPE_FIELDS (TREE_TYPE (tmp));
276 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
277 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
279 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
280 tmp, field, NULL_TREE);
285 gfc_conv_descriptor_stride_get (tree desc, tree dim)
287 tree type = TREE_TYPE (desc);
288 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
289 if (integer_zerop (dim)
290 && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
291 return gfc_index_one_node;
293 return gfc_conv_descriptor_stride (desc, dim);
297 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
298 tree dim, tree value)
300 tree t = gfc_conv_descriptor_stride (desc, dim);
301 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
305 gfc_conv_descriptor_lbound (tree desc, tree dim)
310 tmp = gfc_conv_descriptor_dimension (desc, dim);
311 field = TYPE_FIELDS (TREE_TYPE (tmp));
312 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
313 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
315 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
316 tmp, field, NULL_TREE);
321 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
323 return gfc_conv_descriptor_lbound (desc, dim);
327 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
328 tree dim, tree value)
330 tree t = gfc_conv_descriptor_lbound (desc, dim);
331 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
335 gfc_conv_descriptor_ubound (tree desc, tree dim)
340 tmp = gfc_conv_descriptor_dimension (desc, dim);
341 field = TYPE_FIELDS (TREE_TYPE (tmp));
342 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
343 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
345 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
346 tmp, field, NULL_TREE);
351 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
353 return gfc_conv_descriptor_ubound (desc, dim);
357 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
358 tree dim, tree value)
360 tree t = gfc_conv_descriptor_ubound (desc, dim);
361 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
364 /* Build a null array descriptor constructor. */
367 gfc_build_null_descriptor (tree type)
372 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
373 gcc_assert (DATA_FIELD == 0);
374 field = TYPE_FIELDS (type);
376 /* Set a NULL data pointer. */
377 tmp = build_constructor_single (type, field, null_pointer_node);
378 TREE_CONSTANT (tmp) = 1;
379 /* All other fields are ignored. */
385 /* Cleanup those #defines. */
390 #undef DIMENSION_FIELD
391 #undef STRIDE_SUBFIELD
392 #undef LBOUND_SUBFIELD
393 #undef UBOUND_SUBFIELD
396 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
397 flags & 1 = Main loop body.
398 flags & 2 = temp copy loop. */
401 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
403 for (; ss != gfc_ss_terminator; ss = ss->next)
404 ss->useflags = flags;
407 static void gfc_free_ss (gfc_ss *);
410 /* Free a gfc_ss chain. */
413 gfc_free_ss_chain (gfc_ss * ss)
417 while (ss != gfc_ss_terminator)
419 gcc_assert (ss != NULL);
430 gfc_free_ss (gfc_ss * ss)
437 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
439 if (ss->data.info.subscript[n])
440 gfc_free_ss_chain (ss->data.info.subscript[n]);
452 /* Free all the SS associated with a loop. */
455 gfc_cleanup_loop (gfc_loopinfo * loop)
461 while (ss != gfc_ss_terminator)
463 gcc_assert (ss != NULL);
464 next = ss->loop_chain;
471 /* Associate a SS chain with a loop. */
474 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
478 if (head == gfc_ss_terminator)
482 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
484 if (ss->next == gfc_ss_terminator)
485 ss->loop_chain = loop->ss;
487 ss->loop_chain = ss->next;
489 gcc_assert (ss == gfc_ss_terminator);
494 /* Generate an initializer for a static pointer or allocatable array. */
497 gfc_trans_static_array_pointer (gfc_symbol * sym)
501 gcc_assert (TREE_STATIC (sym->backend_decl));
502 /* Just zero the data member. */
503 type = TREE_TYPE (sym->backend_decl);
504 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
508 /* If the bounds of SE's loop have not yet been set, see if they can be
509 determined from array spec AS, which is the array spec of a called
510 function. MAPPING maps the callee's dummy arguments to the values
511 that the caller is passing. Add any initialization and finalization
515 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
516 gfc_se * se, gfc_array_spec * as)
524 if (as && as->type == AS_EXPLICIT)
525 for (dim = 0; dim < se->loop->dimen; dim++)
527 n = se->loop->order[dim];
528 if (se->loop->to[n] == NULL_TREE)
530 /* Evaluate the lower bound. */
531 gfc_init_se (&tmpse, NULL);
532 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
533 gfc_add_block_to_block (&se->pre, &tmpse.pre);
534 gfc_add_block_to_block (&se->post, &tmpse.post);
535 lower = fold_convert (gfc_array_index_type, tmpse.expr);
537 /* ...and the upper bound. */
538 gfc_init_se (&tmpse, NULL);
539 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
540 gfc_add_block_to_block (&se->pre, &tmpse.pre);
541 gfc_add_block_to_block (&se->post, &tmpse.post);
542 upper = fold_convert (gfc_array_index_type, tmpse.expr);
544 /* Set the upper bound of the loop to UPPER - LOWER. */
545 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
546 tmp = gfc_evaluate_now (tmp, &se->pre);
547 se->loop->to[n] = tmp;
553 /* Generate code to allocate an array temporary, or create a variable to
554 hold the data. If size is NULL, zero the descriptor so that the
555 callee will allocate the array. If DEALLOC is true, also generate code to
556 free the array afterwards.
558 If INITIAL is not NULL, it is packed using internal_pack and the result used
559 as data instead of allocating a fresh, unitialized area of memory.
561 Initialization code is added to PRE and finalization code to POST.
562 DYNAMIC is true if the caller may want to extend the array later
563 using realloc. This prevents us from putting the array on the stack. */
566 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
567 gfc_ss_info * info, tree size, tree nelem,
568 tree initial, bool dynamic, bool dealloc)
574 desc = info->descriptor;
575 info->offset = gfc_index_zero_node;
576 if (size == NULL_TREE || integer_zerop (size))
578 /* A callee allocated array. */
579 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
584 /* Allocate the temporary. */
585 onstack = !dynamic && initial == NULL_TREE
586 && gfc_can_put_var_on_stack (size);
590 /* Make a temporary variable to hold the data. */
591 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
593 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
595 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
597 tmp = gfc_create_var (tmp, "A");
598 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
599 gfc_conv_descriptor_data_set (pre, desc, tmp);
603 /* Allocate memory to hold the data or call internal_pack. */
604 if (initial == NULL_TREE)
606 tmp = gfc_call_malloc (pre, NULL, size);
607 tmp = gfc_evaluate_now (tmp, pre);
614 stmtblock_t do_copying;
616 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
617 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
618 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
619 tmp = gfc_get_element_type (tmp);
620 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
621 packed = gfc_create_var (build_pointer_type (tmp), "data");
623 tmp = build_call_expr_loc (input_location,
624 gfor_fndecl_in_pack, 1, initial);
625 tmp = fold_convert (TREE_TYPE (packed), tmp);
626 gfc_add_modify (pre, packed, tmp);
628 tmp = build_fold_indirect_ref_loc (input_location,
630 source_data = gfc_conv_descriptor_data_get (tmp);
632 /* internal_pack may return source->data without any allocation
633 or copying if it is already packed. If that's the case, we
634 need to allocate and copy manually. */
636 gfc_start_block (&do_copying);
637 tmp = gfc_call_malloc (&do_copying, NULL, size);
638 tmp = fold_convert (TREE_TYPE (packed), tmp);
639 gfc_add_modify (&do_copying, packed, tmp);
640 tmp = gfc_build_memcpy_call (packed, source_data, size);
641 gfc_add_expr_to_block (&do_copying, tmp);
643 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
644 packed, source_data);
645 tmp = gfc_finish_block (&do_copying);
646 tmp = build3_v (COND_EXPR, was_packed, tmp,
647 build_empty_stmt (input_location));
648 gfc_add_expr_to_block (pre, tmp);
650 tmp = fold_convert (pvoid_type_node, packed);
653 gfc_conv_descriptor_data_set (pre, desc, tmp);
656 info->data = gfc_conv_descriptor_data_get (desc);
658 /* The offset is zero because we create temporaries with a zero
660 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
662 if (dealloc && !onstack)
664 /* Free the temporary. */
665 tmp = gfc_conv_descriptor_data_get (desc);
666 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
667 gfc_add_expr_to_block (post, tmp);
672 /* Generate code to create and initialize the descriptor for a temporary
673 array. This is used for both temporaries needed by the scalarizer, and
674 functions returning arrays. Adjusts the loop variables to be
675 zero-based, and calculates the loop bounds for callee allocated arrays.
676 Allocate the array unless it's callee allocated (we have a callee
677 allocated array if 'callee_alloc' is true, or if loop->to[n] is
678 NULL_TREE for any n). Also fills in the descriptor, data and offset
679 fields of info if known. Returns the size of the array, or NULL for a
680 callee allocated array.
682 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
683 gfc_trans_allocate_array_storage.
687 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
688 gfc_loopinfo * loop, gfc_ss_info * info,
689 tree eltype, tree initial, bool dynamic,
690 bool dealloc, bool callee_alloc, locus * where)
702 gcc_assert (info->dimen > 0);
704 if (gfc_option.warn_array_temp && where)
705 gfc_warning ("Creating array temporary at %L", where);
707 /* Set the lower bound to zero. */
708 for (dim = 0; dim < info->dimen; dim++)
710 n = loop->order[dim];
711 /* Callee allocated arrays may not have a known bound yet. */
713 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
714 gfc_array_index_type,
715 loop->to[n], loop->from[n]), pre);
716 loop->from[n] = gfc_index_zero_node;
718 info->delta[dim] = gfc_index_zero_node;
719 info->start[dim] = gfc_index_zero_node;
720 info->end[dim] = gfc_index_zero_node;
721 info->stride[dim] = gfc_index_one_node;
722 info->dim[dim] = dim;
725 /* Initialize the descriptor. */
727 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
728 GFC_ARRAY_UNKNOWN, true);
729 desc = gfc_create_var (type, "atmp");
730 GFC_DECL_PACKED_ARRAY (desc) = 1;
732 info->descriptor = desc;
733 size = gfc_index_one_node;
735 /* Fill in the array dtype. */
736 tmp = gfc_conv_descriptor_dtype (desc);
737 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
740 Fill in the bounds and stride. This is a packed array, so:
743 for (n = 0; n < rank; n++)
746 delta = ubound[n] + 1 - lbound[n];
749 size = size * sizeof(element);
754 /* If there is at least one null loop->to[n], it is a callee allocated
756 for (n = 0; n < info->dimen; n++)
757 if (loop->to[n] == NULL_TREE)
763 for (n = 0; n < info->dimen; n++)
765 if (size == NULL_TREE)
767 /* For a callee allocated array express the loop bounds in terms
768 of the descriptor fields. */
770 fold_build2 (MINUS_EXPR, gfc_array_index_type,
771 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
772 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
777 /* Store the stride and bound components in the descriptor. */
778 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
780 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
781 gfc_index_zero_node);
783 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
785 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
786 loop->to[n], gfc_index_one_node);
788 /* Check whether the size for this dimension is negative. */
789 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
790 gfc_index_zero_node);
791 cond = gfc_evaluate_now (cond, pre);
796 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
798 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
799 size = gfc_evaluate_now (size, pre);
802 /* Get the size of the array. */
804 if (size && !callee_alloc)
806 /* If or_expr is true, then the extent in at least one
807 dimension is zero and the size is set to zero. */
808 size = fold_build3 (COND_EXPR, gfc_array_index_type,
809 or_expr, gfc_index_zero_node, size);
812 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
813 fold_convert (gfc_array_index_type,
814 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
822 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
825 if (info->dimen > loop->temp_dim)
826 loop->temp_dim = info->dimen;
832 /* Generate code to transpose array EXPR by creating a new descriptor
833 in which the dimension specifications have been reversed. */
836 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
838 tree dest, src, dest_index, src_index;
840 gfc_ss_info *dest_info;
841 gfc_ss *dest_ss, *src_ss;
847 src_ss = gfc_walk_expr (expr);
850 dest_info = &dest_ss->data.info;
851 gcc_assert (dest_info->dimen == 2);
853 /* Get a descriptor for EXPR. */
854 gfc_init_se (&src_se, NULL);
855 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
856 gfc_add_block_to_block (&se->pre, &src_se.pre);
857 gfc_add_block_to_block (&se->post, &src_se.post);
860 /* Allocate a new descriptor for the return value. */
861 dest = gfc_create_var (TREE_TYPE (src), "atmp");
862 dest_info->descriptor = dest;
865 /* Copy across the dtype field. */
866 gfc_add_modify (&se->pre,
867 gfc_conv_descriptor_dtype (dest),
868 gfc_conv_descriptor_dtype (src));
870 /* Copy the dimension information, renumbering dimension 1 to 0 and
872 for (n = 0; n < 2; n++)
874 dest_info->delta[n] = gfc_index_zero_node;
875 dest_info->start[n] = gfc_index_zero_node;
876 dest_info->end[n] = gfc_index_zero_node;
877 dest_info->stride[n] = gfc_index_one_node;
878 dest_info->dim[n] = n;
880 dest_index = gfc_rank_cst[n];
881 src_index = gfc_rank_cst[1 - n];
883 gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
884 gfc_conv_descriptor_stride_get (src, src_index));
886 gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
887 gfc_conv_descriptor_lbound_get (src, src_index));
889 gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
890 gfc_conv_descriptor_ubound_get (src, src_index));
894 gcc_assert (integer_zerop (loop->from[n]));
896 fold_build2 (MINUS_EXPR, gfc_array_index_type,
897 gfc_conv_descriptor_ubound_get (dest, dest_index),
898 gfc_conv_descriptor_lbound_get (dest, dest_index));
902 /* Copy the data pointer. */
903 dest_info->data = gfc_conv_descriptor_data_get (src);
904 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
906 /* Copy the offset. This is not changed by transposition; the top-left
907 element is still at the same offset as before, except where the loop
909 if (!integer_zerop (loop->from[0]))
910 dest_info->offset = gfc_conv_descriptor_offset_get (src);
912 dest_info->offset = gfc_index_zero_node;
914 gfc_conv_descriptor_offset_set (&se->pre, dest,
917 if (dest_info->dimen > loop->temp_dim)
918 loop->temp_dim = dest_info->dimen;
922 /* Return the number of iterations in a loop that starts at START,
923 ends at END, and has step STEP. */
926 gfc_get_iteration_count (tree start, tree end, tree step)
931 type = TREE_TYPE (step);
932 tmp = fold_build2 (MINUS_EXPR, type, end, start);
933 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
934 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
935 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
936 return fold_convert (gfc_array_index_type, tmp);
940 /* Extend the data in array DESC by EXTRA elements. */
943 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
950 if (integer_zerop (extra))
953 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
955 /* Add EXTRA to the upper bound. */
956 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
957 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
959 /* Get the value of the current data pointer. */
960 arg0 = gfc_conv_descriptor_data_get (desc);
962 /* Calculate the new array size. */
963 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
964 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
965 ubound, gfc_index_one_node);
966 arg1 = fold_build2 (MULT_EXPR, size_type_node,
967 fold_convert (size_type_node, tmp),
968 fold_convert (size_type_node, size));
970 /* Call the realloc() function. */
971 tmp = gfc_call_realloc (pblock, arg0, arg1);
972 gfc_conv_descriptor_data_set (pblock, desc, tmp);
976 /* Return true if the bounds of iterator I can only be determined
980 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
982 return (i->start->expr_type != EXPR_CONSTANT
983 || i->end->expr_type != EXPR_CONSTANT
984 || i->step->expr_type != EXPR_CONSTANT);
988 /* Split the size of constructor element EXPR into the sum of two terms,
989 one of which can be determined at compile time and one of which must
990 be calculated at run time. Set *SIZE to the former and return true
991 if the latter might be nonzero. */
994 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
996 if (expr->expr_type == EXPR_ARRAY)
997 return gfc_get_array_constructor_size (size, expr->value.constructor);
998 else if (expr->rank > 0)
1000 /* Calculate everything at run time. */
1001 mpz_set_ui (*size, 0);
1006 /* A single element. */
1007 mpz_set_ui (*size, 1);
1013 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1014 of array constructor C. */
1017 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
1024 mpz_set_ui (*size, 0);
1029 for (; c; c = c->next)
1032 if (i && gfc_iterator_has_dynamic_bounds (i))
1036 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1039 /* Multiply the static part of the element size by the
1040 number of iterations. */
1041 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1042 mpz_fdiv_q (val, val, i->step->value.integer);
1043 mpz_add_ui (val, val, 1);
1044 if (mpz_sgn (val) > 0)
1045 mpz_mul (len, len, val);
1047 mpz_set_ui (len, 0);
1049 mpz_add (*size, *size, len);
1058 /* Make sure offset is a variable. */
1061 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1064 /* We should have already created the offset variable. We cannot
1065 create it here because we may be in an inner scope. */
1066 gcc_assert (*offsetvar != NULL_TREE);
1067 gfc_add_modify (pblock, *offsetvar, *poffset);
1068 *poffset = *offsetvar;
1069 TREE_USED (*offsetvar) = 1;
1073 /* Variables needed for bounds-checking. */
1074 static bool first_len;
1075 static tree first_len_val;
1076 static bool typespec_chararray_ctor;
1079 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1080 tree offset, gfc_se * se, gfc_expr * expr)
1084 gfc_conv_expr (se, expr);
1086 /* Store the value. */
1087 tmp = build_fold_indirect_ref_loc (input_location,
1088 gfc_conv_descriptor_data_get (desc));
1089 tmp = gfc_build_array_ref (tmp, offset, NULL);
1091 if (expr->ts.type == BT_CHARACTER)
1093 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1096 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1097 esize = fold_convert (gfc_charlen_type_node, esize);
1098 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1099 build_int_cst (gfc_charlen_type_node,
1100 gfc_character_kinds[i].bit_size / 8));
1102 gfc_conv_string_parameter (se);
1103 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1105 /* The temporary is an array of pointers. */
1106 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1107 gfc_add_modify (&se->pre, tmp, se->expr);
1111 /* The temporary is an array of string values. */
1112 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1113 /* We know the temporary and the value will be the same length,
1114 so can use memcpy. */
1115 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1116 se->string_length, se->expr, expr->ts.kind);
1118 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1122 gfc_add_modify (&se->pre, first_len_val,
1128 /* Verify that all constructor elements are of the same
1130 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1131 first_len_val, se->string_length);
1132 gfc_trans_runtime_check
1133 (true, false, cond, &se->pre, &expr->where,
1134 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1135 fold_convert (long_integer_type_node, first_len_val),
1136 fold_convert (long_integer_type_node, se->string_length));
1142 /* TODO: Should the frontend already have done this conversion? */
1143 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1144 gfc_add_modify (&se->pre, tmp, se->expr);
1147 gfc_add_block_to_block (pblock, &se->pre);
1148 gfc_add_block_to_block (pblock, &se->post);
1152 /* Add the contents of an array to the constructor. DYNAMIC is as for
1153 gfc_trans_array_constructor_value. */
1156 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1157 tree type ATTRIBUTE_UNUSED,
1158 tree desc, gfc_expr * expr,
1159 tree * poffset, tree * offsetvar,
1170 /* We need this to be a variable so we can increment it. */
1171 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1173 gfc_init_se (&se, NULL);
1175 /* Walk the array expression. */
1176 ss = gfc_walk_expr (expr);
1177 gcc_assert (ss != gfc_ss_terminator);
1179 /* Initialize the scalarizer. */
1180 gfc_init_loopinfo (&loop);
1181 gfc_add_ss_to_loop (&loop, ss);
1183 /* Initialize the loop. */
1184 gfc_conv_ss_startstride (&loop);
1185 gfc_conv_loop_setup (&loop, &expr->where);
1187 /* Make sure the constructed array has room for the new data. */
1190 /* Set SIZE to the total number of elements in the subarray. */
1191 size = gfc_index_one_node;
1192 for (n = 0; n < loop.dimen; n++)
1194 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1195 gfc_index_one_node);
1196 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1199 /* Grow the constructed array by SIZE elements. */
1200 gfc_grow_array (&loop.pre, desc, size);
1203 /* Make the loop body. */
1204 gfc_mark_ss_chain_used (ss, 1);
1205 gfc_start_scalarized_body (&loop, &body);
1206 gfc_copy_loopinfo_to_se (&se, &loop);
1209 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1210 gcc_assert (se.ss == gfc_ss_terminator);
1212 /* Increment the offset. */
1213 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1214 *poffset, gfc_index_one_node);
1215 gfc_add_modify (&body, *poffset, tmp);
1217 /* Finish the loop. */
1218 gfc_trans_scalarizing_loops (&loop, &body);
1219 gfc_add_block_to_block (&loop.pre, &loop.post);
1220 tmp = gfc_finish_block (&loop.pre);
1221 gfc_add_expr_to_block (pblock, tmp);
1223 gfc_cleanup_loop (&loop);
1227 /* Assign the values to the elements of an array constructor. DYNAMIC
1228 is true if descriptor DESC only contains enough data for the static
1229 size calculated by gfc_get_array_constructor_size. When true, memory
1230 for the dynamic parts must be allocated using realloc. */
1233 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1234 tree desc, gfc_constructor * c,
1235 tree * poffset, tree * offsetvar,
1243 tree shadow_loopvar = NULL_TREE;
1244 gfc_saved_var saved_loopvar;
1247 for (; c; c = c->next)
1249 /* If this is an iterator or an array, the offset must be a variable. */
1250 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1251 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1253 /* Shadowing the iterator avoids changing its value and saves us from
1254 keeping track of it. Further, it makes sure that there's always a
1255 backend-decl for the symbol, even if there wasn't one before,
1256 e.g. in the case of an iterator that appears in a specification
1257 expression in an interface mapping. */
1260 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1261 tree type = gfc_typenode_for_spec (&sym->ts);
1263 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1264 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1267 gfc_start_block (&body);
1269 if (c->expr->expr_type == EXPR_ARRAY)
1271 /* Array constructors can be nested. */
1272 gfc_trans_array_constructor_value (&body, type, desc,
1273 c->expr->value.constructor,
1274 poffset, offsetvar, dynamic);
1276 else if (c->expr->rank > 0)
1278 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1279 poffset, offsetvar, dynamic);
1283 /* This code really upsets the gimplifier so don't bother for now. */
1290 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1297 /* Scalar values. */
1298 gfc_init_se (&se, NULL);
1299 gfc_trans_array_ctor_element (&body, desc, *poffset,
1302 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1303 *poffset, gfc_index_one_node);
1307 /* Collect multiple scalar constants into a constructor. */
1312 HOST_WIDE_INT idx = 0;
1316 /* Count the number of consecutive scalar constants. */
1317 while (p && !(p->iterator
1318 || p->expr->expr_type != EXPR_CONSTANT))
1320 gfc_init_se (&se, NULL);
1321 gfc_conv_constant (&se, p->expr);
1323 if (c->expr->ts.type != BT_CHARACTER)
1324 se.expr = fold_convert (type, se.expr);
1325 /* For constant character array constructors we build
1326 an array of pointers. */
1327 else if (POINTER_TYPE_P (type))
1328 se.expr = gfc_build_addr_expr
1329 (gfc_get_pchar_type (p->expr->ts.kind),
1332 list = tree_cons (build_int_cst (gfc_array_index_type,
1333 idx++), se.expr, list);
1338 bound = build_int_cst (NULL_TREE, n - 1);
1339 /* Create an array type to hold them. */
1340 tmptype = build_range_type (gfc_array_index_type,
1341 gfc_index_zero_node, bound);
1342 tmptype = build_array_type (type, tmptype);
1344 init = build_constructor_from_list (tmptype, nreverse (list));
1345 TREE_CONSTANT (init) = 1;
1346 TREE_STATIC (init) = 1;
1347 /* Create a static variable to hold the data. */
1348 tmp = gfc_create_var (tmptype, "data");
1349 TREE_STATIC (tmp) = 1;
1350 TREE_CONSTANT (tmp) = 1;
1351 TREE_READONLY (tmp) = 1;
1352 DECL_INITIAL (tmp) = init;
1355 /* Use BUILTIN_MEMCPY to assign the values. */
1356 tmp = gfc_conv_descriptor_data_get (desc);
1357 tmp = build_fold_indirect_ref_loc (input_location,
1359 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1360 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1361 init = gfc_build_addr_expr (NULL_TREE, init);
1363 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1364 bound = build_int_cst (NULL_TREE, n * size);
1365 tmp = build_call_expr_loc (input_location,
1366 built_in_decls[BUILT_IN_MEMCPY], 3,
1368 gfc_add_expr_to_block (&body, tmp);
1370 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1372 build_int_cst (gfc_array_index_type, n));
1374 if (!INTEGER_CST_P (*poffset))
1376 gfc_add_modify (&body, *offsetvar, *poffset);
1377 *poffset = *offsetvar;
1381 /* The frontend should already have done any expansions
1385 /* Pass the code as is. */
1386 tmp = gfc_finish_block (&body);
1387 gfc_add_expr_to_block (pblock, tmp);
1391 /* Build the implied do-loop. */
1392 stmtblock_t implied_do_block;
1400 loopbody = gfc_finish_block (&body);
1402 /* Create a new block that holds the implied-do loop. A temporary
1403 loop-variable is used. */
1404 gfc_start_block(&implied_do_block);
1406 /* Initialize the loop. */
1407 gfc_init_se (&se, NULL);
1408 gfc_conv_expr_val (&se, c->iterator->start);
1409 gfc_add_block_to_block (&implied_do_block, &se.pre);
1410 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1412 gfc_init_se (&se, NULL);
1413 gfc_conv_expr_val (&se, c->iterator->end);
1414 gfc_add_block_to_block (&implied_do_block, &se.pre);
1415 end = gfc_evaluate_now (se.expr, &implied_do_block);
1417 gfc_init_se (&se, NULL);
1418 gfc_conv_expr_val (&se, c->iterator->step);
1419 gfc_add_block_to_block (&implied_do_block, &se.pre);
1420 step = gfc_evaluate_now (se.expr, &implied_do_block);
1422 /* If this array expands dynamically, and the number of iterations
1423 is not constant, we won't have allocated space for the static
1424 part of C->EXPR's size. Do that now. */
1425 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1427 /* Get the number of iterations. */
1428 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1430 /* Get the static part of C->EXPR's size. */
1431 gfc_get_array_constructor_element_size (&size, c->expr);
1432 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1434 /* Grow the array by TMP * TMP2 elements. */
1435 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1436 gfc_grow_array (&implied_do_block, desc, tmp);
1439 /* Generate the loop body. */
1440 exit_label = gfc_build_label_decl (NULL_TREE);
1441 gfc_start_block (&body);
1443 /* Generate the exit condition. Depending on the sign of
1444 the step variable we have to generate the correct
1446 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1447 build_int_cst (TREE_TYPE (step), 0));
1448 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1449 fold_build2 (GT_EXPR, boolean_type_node,
1450 shadow_loopvar, end),
1451 fold_build2 (LT_EXPR, boolean_type_node,
1452 shadow_loopvar, end));
1453 tmp = build1_v (GOTO_EXPR, exit_label);
1454 TREE_USED (exit_label) = 1;
1455 tmp = build3_v (COND_EXPR, cond, tmp,
1456 build_empty_stmt (input_location));
1457 gfc_add_expr_to_block (&body, tmp);
1459 /* The main loop body. */
1460 gfc_add_expr_to_block (&body, loopbody);
1462 /* Increase loop variable by step. */
1463 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1464 gfc_add_modify (&body, shadow_loopvar, tmp);
1466 /* Finish the loop. */
1467 tmp = gfc_finish_block (&body);
1468 tmp = build1_v (LOOP_EXPR, tmp);
1469 gfc_add_expr_to_block (&implied_do_block, tmp);
1471 /* Add the exit label. */
1472 tmp = build1_v (LABEL_EXPR, exit_label);
1473 gfc_add_expr_to_block (&implied_do_block, tmp);
1475 /* Finishe the implied-do loop. */
1476 tmp = gfc_finish_block(&implied_do_block);
1477 gfc_add_expr_to_block(pblock, tmp);
1479 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1486 /* Figure out the string length of a variable reference expression.
1487 Used by get_array_ctor_strlen. */
1490 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1496 /* Don't bother if we already know the length is a constant. */
1497 if (*len && INTEGER_CST_P (*len))
1500 ts = &expr->symtree->n.sym->ts;
1501 for (ref = expr->ref; ref; ref = ref->next)
1506 /* Array references don't change the string length. */
1510 /* Use the length of the component. */
1511 ts = &ref->u.c.component->ts;
1515 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1516 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1518 mpz_init_set_ui (char_len, 1);
1519 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1520 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1521 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1522 *len = convert (gfc_charlen_type_node, *len);
1523 mpz_clear (char_len);
1527 /* TODO: Substrings are tricky because we can't evaluate the
1528 expression more than once. For now we just give up, and hope
1529 we can figure it out elsewhere. */
1534 *len = ts->u.cl->backend_decl;
1538 /* A catch-all to obtain the string length for anything that is not a
1539 constant, array or variable. */
1541 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1546 /* Don't bother if we already know the length is a constant. */
1547 if (*len && INTEGER_CST_P (*len))
1550 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1551 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1554 gfc_conv_const_charlen (e->ts.u.cl);
1555 *len = e->ts.u.cl->backend_decl;
1559 /* Otherwise, be brutal even if inefficient. */
1560 ss = gfc_walk_expr (e);
1561 gfc_init_se (&se, NULL);
1563 /* No function call, in case of side effects. */
1564 se.no_function_call = 1;
1565 if (ss == gfc_ss_terminator)
1566 gfc_conv_expr (&se, e);
1568 gfc_conv_expr_descriptor (&se, e, ss);
1570 /* Fix the value. */
1571 *len = gfc_evaluate_now (se.string_length, &se.pre);
1573 gfc_add_block_to_block (block, &se.pre);
1574 gfc_add_block_to_block (block, &se.post);
1576 e->ts.u.cl->backend_decl = *len;
1581 /* Figure out the string length of a character array constructor.
1582 If len is NULL, don't calculate the length; this happens for recursive calls
1583 when a sub-array-constructor is an element but not at the first position,
1584 so when we're not interested in the length.
1585 Returns TRUE if all elements are character constants. */
1588 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1597 *len = build_int_cstu (gfc_charlen_type_node, 0);
1601 /* Loop over all constructor elements to find out is_const, but in len we
1602 want to store the length of the first, not the last, element. We can
1603 of course exit the loop as soon as is_const is found to be false. */
1604 for (; c && is_const; c = c->next)
1606 switch (c->expr->expr_type)
1609 if (len && !(*len && INTEGER_CST_P (*len)))
1610 *len = build_int_cstu (gfc_charlen_type_node,
1611 c->expr->value.character.length);
1615 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1622 get_array_ctor_var_strlen (c->expr, len);
1628 get_array_ctor_all_strlen (block, c->expr, len);
1632 /* After the first iteration, we don't want the length modified. */
1639 /* Check whether the array constructor C consists entirely of constant
1640 elements, and if so returns the number of those elements, otherwise
1641 return zero. Note, an empty or NULL array constructor returns zero. */
1643 unsigned HOST_WIDE_INT
1644 gfc_constant_array_constructor_p (gfc_constructor * c)
1646 unsigned HOST_WIDE_INT nelem = 0;
1651 || c->expr->rank > 0
1652 || c->expr->expr_type != EXPR_CONSTANT)
1661 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1662 and the tree type of it's elements, TYPE, return a static constant
1663 variable that is compile-time initialized. */
1666 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1668 tree tmptype, list, init, tmp;
1669 HOST_WIDE_INT nelem;
1675 /* First traverse the constructor list, converting the constants
1676 to tree to build an initializer. */
1679 c = expr->value.constructor;
1682 gfc_init_se (&se, NULL);
1683 gfc_conv_constant (&se, c->expr);
1684 if (c->expr->ts.type != BT_CHARACTER)
1685 se.expr = fold_convert (type, se.expr);
1686 else if (POINTER_TYPE_P (type))
1687 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1689 list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1695 /* Next determine the tree type for the array. We use the gfortran
1696 front-end's gfc_get_nodesc_array_type in order to create a suitable
1697 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1699 memset (&as, 0, sizeof (gfc_array_spec));
1701 as.rank = expr->rank;
1702 as.type = AS_EXPLICIT;
1705 as.lower[0] = gfc_int_expr (0);
1706 as.upper[0] = gfc_int_expr (nelem - 1);
1709 for (i = 0; i < expr->rank; i++)
1711 int tmp = (int) mpz_get_si (expr->shape[i]);
1712 as.lower[i] = gfc_int_expr (0);
1713 as.upper[i] = gfc_int_expr (tmp - 1);
1716 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1718 init = build_constructor_from_list (tmptype, nreverse (list));
1720 TREE_CONSTANT (init) = 1;
1721 TREE_STATIC (init) = 1;
1723 tmp = gfc_create_var (tmptype, "A");
1724 TREE_STATIC (tmp) = 1;
1725 TREE_CONSTANT (tmp) = 1;
1726 TREE_READONLY (tmp) = 1;
1727 DECL_INITIAL (tmp) = init;
1733 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1734 This mostly initializes the scalarizer state info structure with the
1735 appropriate values to directly use the array created by the function
1736 gfc_build_constant_array_constructor. */
1739 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1740 gfc_ss * ss, tree type)
1746 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1748 info = &ss->data.info;
1750 info->descriptor = tmp;
1751 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1752 info->offset = gfc_index_zero_node;
1754 for (i = 0; i < info->dimen; i++)
1756 info->delta[i] = gfc_index_zero_node;
1757 info->start[i] = gfc_index_zero_node;
1758 info->end[i] = gfc_index_zero_node;
1759 info->stride[i] = gfc_index_one_node;
1763 if (info->dimen > loop->temp_dim)
1764 loop->temp_dim = info->dimen;
1767 /* Helper routine of gfc_trans_array_constructor to determine if the
1768 bounds of the loop specified by LOOP are constant and simple enough
1769 to use with gfc_trans_constant_array_constructor. Returns the
1770 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1773 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1775 tree size = gfc_index_one_node;
1779 for (i = 0; i < loop->dimen; i++)
1781 /* If the bounds aren't constant, return NULL_TREE. */
1782 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1784 if (!integer_zerop (loop->from[i]))
1786 /* Only allow nonzero "from" in one-dimensional arrays. */
1787 if (loop->dimen != 1)
1789 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1790 loop->to[i], loop->from[i]);
1794 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1795 tmp, gfc_index_one_node);
1796 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1803 /* Array constructors are handled by constructing a temporary, then using that
1804 within the scalarization loop. This is not optimal, but seems by far the
1808 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1816 bool old_first_len, old_typespec_chararray_ctor;
1817 tree old_first_len_val;
1819 /* Save the old values for nested checking. */
1820 old_first_len = first_len;
1821 old_first_len_val = first_len_val;
1822 old_typespec_chararray_ctor = typespec_chararray_ctor;
1824 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1825 typespec was given for the array constructor. */
1826 typespec_chararray_ctor = (ss->expr->ts.u.cl
1827 && ss->expr->ts.u.cl->length_from_typespec);
1829 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1830 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1832 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1836 ss->data.info.dimen = loop->dimen;
1838 c = ss->expr->value.constructor;
1839 if (ss->expr->ts.type == BT_CHARACTER)
1843 /* get_array_ctor_strlen walks the elements of the constructor, if a
1844 typespec was given, we already know the string length and want the one
1846 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1847 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1851 const_string = false;
1852 gfc_init_se (&length_se, NULL);
1853 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1854 gfc_charlen_type_node);
1855 ss->string_length = length_se.expr;
1856 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1857 gfc_add_block_to_block (&loop->post, &length_se.post);
1860 const_string = get_array_ctor_strlen (&loop->pre, c,
1861 &ss->string_length);
1863 /* Complex character array constructors should have been taken care of
1864 and not end up here. */
1865 gcc_assert (ss->string_length);
1867 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1869 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1871 type = build_pointer_type (type);
1874 type = gfc_typenode_for_spec (&ss->expr->ts);
1876 /* See if the constructor determines the loop bounds. */
1879 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1881 /* We have a multidimensional parameter. */
1883 for (n = 0; n < ss->expr->rank; n++)
1885 loop->from[n] = gfc_index_zero_node;
1886 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1887 gfc_index_integer_kind);
1888 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1889 loop->to[n], gfc_index_one_node);
1893 if (loop->to[0] == NULL_TREE)
1897 /* We should have a 1-dimensional, zero-based loop. */
1898 gcc_assert (loop->dimen == 1);
1899 gcc_assert (integer_zerop (loop->from[0]));
1901 /* Split the constructor size into a static part and a dynamic part.
1902 Allocate the static size up-front and record whether the dynamic
1903 size might be nonzero. */
1905 dynamic = gfc_get_array_constructor_size (&size, c);
1906 mpz_sub_ui (size, size, 1);
1907 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1911 /* Special case constant array constructors. */
1914 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1917 tree size = constant_array_constructor_loop_size (loop);
1918 if (size && compare_tree_int (size, nelem) == 0)
1920 gfc_trans_constant_array_constructor (loop, ss, type);
1926 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1927 type, NULL_TREE, dynamic, true, false, where);
1929 desc = ss->data.info.descriptor;
1930 offset = gfc_index_zero_node;
1931 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1932 TREE_NO_WARNING (offsetvar) = 1;
1933 TREE_USED (offsetvar) = 0;
1934 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1935 &offset, &offsetvar, dynamic);
1937 /* If the array grows dynamically, the upper bound of the loop variable
1938 is determined by the array's final upper bound. */
1940 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1942 if (TREE_USED (offsetvar))
1943 pushdecl (offsetvar);
1945 gcc_assert (INTEGER_CST_P (offset));
1947 /* Disable bound checking for now because it's probably broken. */
1948 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1955 /* Restore old values of globals. */
1956 first_len = old_first_len;
1957 first_len_val = old_first_len_val;
1958 typespec_chararray_ctor = old_typespec_chararray_ctor;
1962 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1963 called after evaluating all of INFO's vector dimensions. Go through
1964 each such vector dimension and see if we can now fill in any missing
1968 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1977 for (n = 0; n < loop->dimen; n++)
1980 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1981 && loop->to[n] == NULL)
1983 /* Loop variable N indexes vector dimension DIM, and we don't
1984 yet know the upper bound of loop variable N. Set it to the
1985 difference between the vector's upper and lower bounds. */
1986 gcc_assert (loop->from[n] == gfc_index_zero_node);
1987 gcc_assert (info->subscript[dim]
1988 && info->subscript[dim]->type == GFC_SS_VECTOR);
1990 gfc_init_se (&se, NULL);
1991 desc = info->subscript[dim]->data.info.descriptor;
1992 zero = gfc_rank_cst[0];
1993 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1994 gfc_conv_descriptor_ubound_get (desc, zero),
1995 gfc_conv_descriptor_lbound_get (desc, zero));
1996 tmp = gfc_evaluate_now (tmp, &loop->pre);
2003 /* Add the pre and post chains for all the scalar expressions in a SS chain
2004 to loop. This is called after the loop parameters have been calculated,
2005 but before the actual scalarizing loops. */
2008 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2014 /* TODO: This can generate bad code if there are ordering dependencies,
2015 e.g., a callee allocated function and an unknown size constructor. */
2016 gcc_assert (ss != NULL);
2018 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2025 /* Scalar expression. Evaluate this now. This includes elemental
2026 dimension indices, but not array section bounds. */
2027 gfc_init_se (&se, NULL);
2028 gfc_conv_expr (&se, ss->expr);
2029 gfc_add_block_to_block (&loop->pre, &se.pre);
2031 if (ss->expr->ts.type != BT_CHARACTER)
2033 /* Move the evaluation of scalar expressions outside the
2034 scalarization loop, except for WHERE assignments. */
2036 se.expr = convert(gfc_array_index_type, se.expr);
2038 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2039 gfc_add_block_to_block (&loop->pre, &se.post);
2042 gfc_add_block_to_block (&loop->post, &se.post);
2044 ss->data.scalar.expr = se.expr;
2045 ss->string_length = se.string_length;
2048 case GFC_SS_REFERENCE:
2049 /* Scalar reference. Evaluate this now. */
2050 gfc_init_se (&se, NULL);
2051 gfc_conv_expr_reference (&se, ss->expr);
2052 gfc_add_block_to_block (&loop->pre, &se.pre);
2053 gfc_add_block_to_block (&loop->post, &se.post);
2055 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2056 ss->string_length = se.string_length;
2059 case GFC_SS_SECTION:
2060 /* Add the expressions for scalar and vector subscripts. */
2061 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2062 if (ss->data.info.subscript[n])
2063 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2066 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2070 /* Get the vector's descriptor and store it in SS. */
2071 gfc_init_se (&se, NULL);
2072 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2073 gfc_add_block_to_block (&loop->pre, &se.pre);
2074 gfc_add_block_to_block (&loop->post, &se.post);
2075 ss->data.info.descriptor = se.expr;
2078 case GFC_SS_INTRINSIC:
2079 gfc_add_intrinsic_ss_code (loop, ss);
2082 case GFC_SS_FUNCTION:
2083 /* Array function return value. We call the function and save its
2084 result in a temporary for use inside the loop. */
2085 gfc_init_se (&se, NULL);
2088 gfc_conv_expr (&se, ss->expr);
2089 gfc_add_block_to_block (&loop->pre, &se.pre);
2090 gfc_add_block_to_block (&loop->post, &se.post);
2091 ss->string_length = se.string_length;
2094 case GFC_SS_CONSTRUCTOR:
2095 if (ss->expr->ts.type == BT_CHARACTER
2096 && ss->string_length == NULL
2097 && ss->expr->ts.u.cl
2098 && ss->expr->ts.u.cl->length)
2100 gfc_init_se (&se, NULL);
2101 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2102 gfc_charlen_type_node);
2103 ss->string_length = se.expr;
2104 gfc_add_block_to_block (&loop->pre, &se.pre);
2105 gfc_add_block_to_block (&loop->post, &se.post);
2107 gfc_trans_array_constructor (loop, ss, where);
2111 case GFC_SS_COMPONENT:
2112 /* Do nothing. These are handled elsewhere. */
2122 /* Translate expressions for the descriptor and data pointer of a SS. */
2126 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2131 /* Get the descriptor for the array to be scalarized. */
2132 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2133 gfc_init_se (&se, NULL);
2134 se.descriptor_only = 1;
2135 gfc_conv_expr_lhs (&se, ss->expr);
2136 gfc_add_block_to_block (block, &se.pre);
2137 ss->data.info.descriptor = se.expr;
2138 ss->string_length = se.string_length;
2142 /* Also the data pointer. */
2143 tmp = gfc_conv_array_data (se.expr);
2144 /* If this is a variable or address of a variable we use it directly.
2145 Otherwise we must evaluate it now to avoid breaking dependency
2146 analysis by pulling the expressions for elemental array indices
2149 || (TREE_CODE (tmp) == ADDR_EXPR
2150 && DECL_P (TREE_OPERAND (tmp, 0)))))
2151 tmp = gfc_evaluate_now (tmp, block);
2152 ss->data.info.data = tmp;
2154 tmp = gfc_conv_array_offset (se.expr);
2155 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2160 /* Initialize a gfc_loopinfo structure. */
2163 gfc_init_loopinfo (gfc_loopinfo * loop)
2167 memset (loop, 0, sizeof (gfc_loopinfo));
2168 gfc_init_block (&loop->pre);
2169 gfc_init_block (&loop->post);
2171 /* Initially scalarize in order. */
2172 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2175 loop->ss = gfc_ss_terminator;
2179 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2183 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2189 /* Return an expression for the data pointer of an array. */
2192 gfc_conv_array_data (tree descriptor)
2196 type = TREE_TYPE (descriptor);
2197 if (GFC_ARRAY_TYPE_P (type))
2199 if (TREE_CODE (type) == POINTER_TYPE)
2203 /* Descriptorless arrays. */
2204 return gfc_build_addr_expr (NULL_TREE, descriptor);
2208 return gfc_conv_descriptor_data_get (descriptor);
2212 /* Return an expression for the base offset of an array. */
2215 gfc_conv_array_offset (tree descriptor)
2219 type = TREE_TYPE (descriptor);
2220 if (GFC_ARRAY_TYPE_P (type))
2221 return GFC_TYPE_ARRAY_OFFSET (type);
2223 return gfc_conv_descriptor_offset_get (descriptor);
2227 /* Get an expression for the array stride. */
2230 gfc_conv_array_stride (tree descriptor, int dim)
2235 type = TREE_TYPE (descriptor);
2237 /* For descriptorless arrays use the array size. */
2238 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2239 if (tmp != NULL_TREE)
2242 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2247 /* Like gfc_conv_array_stride, but for the lower bound. */
2250 gfc_conv_array_lbound (tree descriptor, int dim)
2255 type = TREE_TYPE (descriptor);
2257 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2258 if (tmp != NULL_TREE)
2261 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2266 /* Like gfc_conv_array_stride, but for the upper bound. */
2269 gfc_conv_array_ubound (tree descriptor, int dim)
2274 type = TREE_TYPE (descriptor);
2276 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2277 if (tmp != NULL_TREE)
2280 /* This should only ever happen when passing an assumed shape array
2281 as an actual parameter. The value will never be used. */
2282 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2283 return gfc_index_zero_node;
2285 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2290 /* Generate code to perform an array index bound check. */
2293 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2294 locus * where, bool check_upper)
2297 tree tmp_lo, tmp_up;
2299 const char * name = NULL;
2301 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2304 index = gfc_evaluate_now (index, &se->pre);
2306 /* We find a name for the error message. */
2308 name = se->ss->expr->symtree->name;
2310 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2311 && se->loop->ss->expr->symtree)
2312 name = se->loop->ss->expr->symtree->name;
2314 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2315 && se->loop->ss->loop_chain->expr
2316 && se->loop->ss->loop_chain->expr->symtree)
2317 name = se->loop->ss->loop_chain->expr->symtree->name;
2319 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2320 && se->loop->ss->loop_chain->expr->symtree)
2321 name = se->loop->ss->loop_chain->expr->symtree->name;
2323 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2325 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2326 && se->loop->ss->expr->value.function.name)
2327 name = se->loop->ss->expr->value.function.name;
2329 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2330 || se->loop->ss->type == GFC_SS_SCALAR)
2331 name = "unnamed constant";
2334 /* If upper bound is present, include both bounds in the error message. */
2337 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2338 tmp_up = gfc_conv_array_ubound (descriptor, n);
2341 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2342 "outside of expected range (%%ld:%%ld)", n+1, name);
2344 asprintf (&msg, "Index '%%ld' of dimension %d "
2345 "outside of expected range (%%ld:%%ld)", n+1);
2347 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2348 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2349 fold_convert (long_integer_type_node, index),
2350 fold_convert (long_integer_type_node, tmp_lo),
2351 fold_convert (long_integer_type_node, tmp_up));
2352 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2353 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354 fold_convert (long_integer_type_node, index),
2355 fold_convert (long_integer_type_node, tmp_lo),
2356 fold_convert (long_integer_type_node, tmp_up));
2361 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2364 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2365 "below lower bound of %%ld", n+1, name);
2367 asprintf (&msg, "Index '%%ld' of dimension %d "
2368 "below lower bound of %%ld", n+1);
2370 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2371 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2372 fold_convert (long_integer_type_node, index),
2373 fold_convert (long_integer_type_node, tmp_lo));
2381 /* Return the offset for an index. Performs bound checking for elemental
2382 dimensions. Single element references are processed separately. */
2385 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2386 gfc_array_ref * ar, tree stride)
2392 /* Get the index into the array for this dimension. */
2395 gcc_assert (ar->type != AR_ELEMENT);
2396 switch (ar->dimen_type[dim])
2399 /* Elemental dimension. */
2400 gcc_assert (info->subscript[dim]
2401 && info->subscript[dim]->type == GFC_SS_SCALAR);
2402 /* We've already translated this value outside the loop. */
2403 index = info->subscript[dim]->data.scalar.expr;
2405 index = gfc_trans_array_bound_check (se, info->descriptor,
2406 index, dim, &ar->where,
2407 (ar->as->type != AS_ASSUMED_SIZE
2408 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2412 gcc_assert (info && se->loop);
2413 gcc_assert (info->subscript[dim]
2414 && info->subscript[dim]->type == GFC_SS_VECTOR);
2415 desc = info->subscript[dim]->data.info.descriptor;
2417 /* Get a zero-based index into the vector. */
2418 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2419 se->loop->loopvar[i], se->loop->from[i]);
2421 /* Multiply the index by the stride. */
2422 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2423 index, gfc_conv_array_stride (desc, 0));
2425 /* Read the vector to get an index into info->descriptor. */
2426 data = build_fold_indirect_ref_loc (input_location,
2427 gfc_conv_array_data (desc));
2428 index = gfc_build_array_ref (data, index, NULL);
2429 index = gfc_evaluate_now (index, &se->pre);
2431 /* Do any bounds checking on the final info->descriptor index. */
2432 index = gfc_trans_array_bound_check (se, info->descriptor,
2433 index, dim, &ar->where,
2434 (ar->as->type != AS_ASSUMED_SIZE
2435 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2439 /* Scalarized dimension. */
2440 gcc_assert (info && se->loop);
2442 /* Multiply the loop variable by the stride and delta. */
2443 index = se->loop->loopvar[i];
2444 if (!integer_onep (info->stride[i]))
2445 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2447 if (!integer_zerop (info->delta[i]))
2448 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2458 /* Temporary array or derived type component. */
2459 gcc_assert (se->loop);
2460 index = se->loop->loopvar[se->loop->order[i]];
2461 if (!integer_zerop (info->delta[i]))
2462 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2463 index, info->delta[i]);
2466 /* Multiply by the stride. */
2467 if (!integer_onep (stride))
2468 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2474 /* Build a scalarized reference to an array. */
2477 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2480 tree decl = NULL_TREE;
2485 info = &se->ss->data.info;
2487 n = se->loop->order[0];
2491 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2493 /* Add the offset for this dimension to the stored offset for all other
2495 if (!integer_zerop (info->offset))
2496 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2498 if (se->ss->expr && is_subref_array (se->ss->expr))
2499 decl = se->ss->expr->symtree->n.sym->backend_decl;
2501 tmp = build_fold_indirect_ref_loc (input_location,
2503 se->expr = gfc_build_array_ref (tmp, index, decl);
2507 /* Translate access of temporary array. */
2510 gfc_conv_tmp_array_ref (gfc_se * se)
2512 se->string_length = se->ss->string_length;
2513 gfc_conv_scalarized_array_ref (se, NULL);
2517 /* Build an array reference. se->expr already holds the array descriptor.
2518 This should be either a variable, indirect variable reference or component
2519 reference. For arrays which do not have a descriptor, se->expr will be
2521 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2524 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2534 /* Handle scalarized references separately. */
2535 if (ar->type != AR_ELEMENT)
2537 gfc_conv_scalarized_array_ref (se, ar);
2538 gfc_advance_se_ss_chain (se);
2542 index = gfc_index_zero_node;
2544 /* Calculate the offsets from all the dimensions. */
2545 for (n = 0; n < ar->dimen; n++)
2547 /* Calculate the index for this dimension. */
2548 gfc_init_se (&indexse, se);
2549 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2550 gfc_add_block_to_block (&se->pre, &indexse.pre);
2552 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2554 /* Check array bounds. */
2558 /* Evaluate the indexse.expr only once. */
2559 indexse.expr = save_expr (indexse.expr);
2562 tmp = gfc_conv_array_lbound (se->expr, n);
2563 if (sym->attr.temporary)
2565 gfc_init_se (&tmpse, se);
2566 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2567 gfc_array_index_type);
2568 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2572 cond = fold_build2 (LT_EXPR, boolean_type_node,
2574 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2575 "below lower bound of %%ld", n+1, sym->name);
2576 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2577 fold_convert (long_integer_type_node,
2579 fold_convert (long_integer_type_node, tmp));
2582 /* Upper bound, but not for the last dimension of assumed-size
2584 if (n < ar->dimen - 1
2585 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2587 tmp = gfc_conv_array_ubound (se->expr, n);
2588 if (sym->attr.temporary)
2590 gfc_init_se (&tmpse, se);
2591 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2592 gfc_array_index_type);
2593 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2597 cond = fold_build2 (GT_EXPR, boolean_type_node,
2599 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2600 "above upper bound of %%ld", n+1, sym->name);
2601 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2602 fold_convert (long_integer_type_node,
2604 fold_convert (long_integer_type_node, tmp));
2609 /* Multiply the index by the stride. */
2610 stride = gfc_conv_array_stride (se->expr, n);
2611 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2614 /* And add it to the total. */
2615 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2618 tmp = gfc_conv_array_offset (se->expr);
2619 if (!integer_zerop (tmp))
2620 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2622 /* Access the calculated element. */
2623 tmp = gfc_conv_array_data (se->expr);
2624 tmp = build_fold_indirect_ref (tmp);
2625 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2629 /* Generate the code to be executed immediately before entering a
2630 scalarization loop. */
2633 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2634 stmtblock_t * pblock)
2643 /* This code will be executed before entering the scalarization loop
2644 for this dimension. */
2645 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2647 if ((ss->useflags & flag) == 0)
2650 if (ss->type != GFC_SS_SECTION
2651 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2652 && ss->type != GFC_SS_COMPONENT)
2655 info = &ss->data.info;
2657 if (dim >= info->dimen)
2660 if (dim == info->dimen - 1)
2662 /* For the outermost loop calculate the offset due to any
2663 elemental dimensions. It will have been initialized with the
2664 base offset of the array. */
2667 for (i = 0; i < info->ref->u.ar.dimen; i++)
2669 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2672 gfc_init_se (&se, NULL);
2674 se.expr = info->descriptor;
2675 stride = gfc_conv_array_stride (info->descriptor, i);
2676 index = gfc_conv_array_index_offset (&se, info, i, -1,
2679 gfc_add_block_to_block (pblock, &se.pre);
2681 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2682 info->offset, index);
2683 info->offset = gfc_evaluate_now (info->offset, pblock);
2687 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2690 stride = gfc_conv_array_stride (info->descriptor, 0);
2692 /* Calculate the stride of the innermost loop. Hopefully this will
2693 allow the backend optimizers to do their stuff more effectively.
2695 info->stride0 = gfc_evaluate_now (stride, pblock);
2699 /* Add the offset for the previous loop dimension. */
2704 ar = &info->ref->u.ar;
2705 i = loop->order[dim + 1];
2713 gfc_init_se (&se, NULL);
2715 se.expr = info->descriptor;
2716 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2717 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2719 gfc_add_block_to_block (pblock, &se.pre);
2720 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2721 info->offset, index);
2722 info->offset = gfc_evaluate_now (info->offset, pblock);
2725 /* Remember this offset for the second loop. */
2726 if (dim == loop->temp_dim - 1)
2727 info->saved_offset = info->offset;
2732 /* Start a scalarized expression. Creates a scope and declares loop
2736 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2742 gcc_assert (!loop->array_parameter);
2744 for (dim = loop->dimen - 1; dim >= 0; dim--)
2746 n = loop->order[dim];
2748 gfc_start_block (&loop->code[n]);
2750 /* Create the loop variable. */
2751 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2753 if (dim < loop->temp_dim)
2757 /* Calculate values that will be constant within this loop. */
2758 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2760 gfc_start_block (pbody);
2764 /* Generates the actual loop code for a scalarization loop. */
2767 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2768 stmtblock_t * pbody)
2779 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2780 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2781 && n == loop->dimen - 1)
2783 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2784 init = make_tree_vec (1);
2785 cond = make_tree_vec (1);
2786 incr = make_tree_vec (1);
2788 /* Cycle statement is implemented with a goto. Exit statement must not
2789 be present for this loop. */
2790 exit_label = gfc_build_label_decl (NULL_TREE);
2791 TREE_USED (exit_label) = 1;
2793 /* Label for cycle statements (if needed). */
2794 tmp = build1_v (LABEL_EXPR, exit_label);
2795 gfc_add_expr_to_block (pbody, tmp);
2797 stmt = make_node (OMP_FOR);
2799 TREE_TYPE (stmt) = void_type_node;
2800 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2802 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2803 OMP_CLAUSE_SCHEDULE);
2804 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2805 = OMP_CLAUSE_SCHEDULE_STATIC;
2806 if (ompws_flags & OMPWS_NOWAIT)
2807 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2808 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2810 /* Initialize the loopvar. */
2811 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2813 OMP_FOR_INIT (stmt) = init;
2814 /* The exit condition. */
2815 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2816 loop->loopvar[n], loop->to[n]);
2817 OMP_FOR_COND (stmt) = cond;
2818 /* Increment the loopvar. */
2819 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2820 loop->loopvar[n], gfc_index_one_node);
2821 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2822 void_type_node, loop->loopvar[n], tmp);
2823 OMP_FOR_INCR (stmt) = incr;
2825 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2826 gfc_add_expr_to_block (&loop->code[n], stmt);
2830 loopbody = gfc_finish_block (pbody);
2832 /* Initialize the loopvar. */
2833 if (loop->loopvar[n] != loop->from[n])
2834 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2836 exit_label = gfc_build_label_decl (NULL_TREE);
2838 /* Generate the loop body. */
2839 gfc_init_block (&block);
2841 /* The exit condition. */
2842 cond = fold_build2 (GT_EXPR, boolean_type_node,
2843 loop->loopvar[n], loop->to[n]);
2844 tmp = build1_v (GOTO_EXPR, exit_label);
2845 TREE_USED (exit_label) = 1;
2846 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2847 gfc_add_expr_to_block (&block, tmp);
2849 /* The main body. */
2850 gfc_add_expr_to_block (&block, loopbody);
2852 /* Increment the loopvar. */
2853 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2854 loop->loopvar[n], gfc_index_one_node);
2855 gfc_add_modify (&block, loop->loopvar[n], tmp);
2857 /* Build the loop. */
2858 tmp = gfc_finish_block (&block);
2859 tmp = build1_v (LOOP_EXPR, tmp);
2860 gfc_add_expr_to_block (&loop->code[n], tmp);
2862 /* Add the exit label. */
2863 tmp = build1_v (LABEL_EXPR, exit_label);
2864 gfc_add_expr_to_block (&loop->code[n], tmp);
2870 /* Finishes and generates the loops for a scalarized expression. */
2873 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2878 stmtblock_t *pblock;
2882 /* Generate the loops. */
2883 for (dim = 0; dim < loop->dimen; dim++)
2885 n = loop->order[dim];
2886 gfc_trans_scalarized_loop_end (loop, n, pblock);
2887 loop->loopvar[n] = NULL_TREE;
2888 pblock = &loop->code[n];
2891 tmp = gfc_finish_block (pblock);
2892 gfc_add_expr_to_block (&loop->pre, tmp);
2894 /* Clear all the used flags. */
2895 for (ss = loop->ss; ss; ss = ss->loop_chain)
2900 /* Finish the main body of a scalarized expression, and start the secondary
2904 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2908 stmtblock_t *pblock;
2912 /* We finish as many loops as are used by the temporary. */
2913 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2915 n = loop->order[dim];
2916 gfc_trans_scalarized_loop_end (loop, n, pblock);
2917 loop->loopvar[n] = NULL_TREE;
2918 pblock = &loop->code[n];
2921 /* We don't want to finish the outermost loop entirely. */
2922 n = loop->order[loop->temp_dim - 1];
2923 gfc_trans_scalarized_loop_end (loop, n, pblock);
2925 /* Restore the initial offsets. */
2926 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2928 if ((ss->useflags & 2) == 0)
2931 if (ss->type != GFC_SS_SECTION
2932 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2933 && ss->type != GFC_SS_COMPONENT)
2936 ss->data.info.offset = ss->data.info.saved_offset;
2939 /* Restart all the inner loops we just finished. */
2940 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2942 n = loop->order[dim];
2944 gfc_start_block (&loop->code[n]);
2946 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2948 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2951 /* Start a block for the secondary copying code. */
2952 gfc_start_block (body);
2956 /* Calculate the upper bound of an array section. */
2959 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2968 gcc_assert (ss->type == GFC_SS_SECTION);
2970 info = &ss->data.info;
2973 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2974 /* We'll calculate the upper bound once we have access to the
2975 vector's descriptor. */
2978 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2979 desc = info->descriptor;
2980 end = info->ref->u.ar.end[dim];
2984 /* The upper bound was specified. */
2985 gfc_init_se (&se, NULL);
2986 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2987 gfc_add_block_to_block (pblock, &se.pre);
2992 /* No upper bound was specified, so use the bound of the array. */
2993 bound = gfc_conv_array_ubound (desc, dim);
3000 /* Calculate the lower bound of an array section. */
3003 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3013 gcc_assert (ss->type == GFC_SS_SECTION);
3015 info = &ss->data.info;
3018 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3020 /* We use a zero-based index to access the vector. */
3021 info->start[n] = gfc_index_zero_node;
3022 info->end[n] = gfc_index_zero_node;
3023 info->stride[n] = gfc_index_one_node;
3027 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3028 desc = info->descriptor;
3029 start = info->ref->u.ar.start[dim];
3030 end = info->ref->u.ar.end[dim];
3031 stride = info->ref->u.ar.stride[dim];
3033 /* Calculate the start of the range. For vector subscripts this will
3034 be the range of the vector. */
3037 /* Specified section start. */
3038 gfc_init_se (&se, NULL);
3039 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3040 gfc_add_block_to_block (&loop->pre, &se.pre);
3041 info->start[n] = se.expr;
3045 /* No lower bound specified so use the bound of the array. */
3046 info->start[n] = gfc_conv_array_lbound (desc, dim);
3048 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3050 /* Similarly calculate the end. Although this is not used in the
3051 scalarizer, it is needed when checking bounds and where the end
3052 is an expression with side-effects. */
3055 /* Specified section start. */
3056 gfc_init_se (&se, NULL);
3057 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3058 gfc_add_block_to_block (&loop->pre, &se.pre);
3059 info->end[n] = se.expr;
3063 /* No upper bound specified so use the bound of the array. */
3064 info->end[n] = gfc_conv_array_ubound (desc, dim);
3066 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3068 /* Calculate the stride. */
3070 info->stride[n] = gfc_index_one_node;
3073 gfc_init_se (&se, NULL);
3074 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3075 gfc_add_block_to_block (&loop->pre, &se.pre);
3076 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3081 /* Calculates the range start and stride for a SS chain. Also gets the
3082 descriptor and data pointer. The range of vector subscripts is the size
3083 of the vector. Array bounds are also checked. */
3086 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3094 /* Determine the rank of the loop. */
3096 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3100 case GFC_SS_SECTION:
3101 case GFC_SS_CONSTRUCTOR:
3102 case GFC_SS_FUNCTION:
3103 case GFC_SS_COMPONENT:
3104 loop->dimen = ss->data.info.dimen;
3107 /* As usual, lbound and ubound are exceptions!. */
3108 case GFC_SS_INTRINSIC:
3109 switch (ss->expr->value.function.isym->id)
3111 case GFC_ISYM_LBOUND:
3112 case GFC_ISYM_UBOUND:
3113 loop->dimen = ss->data.info.dimen;
3124 /* We should have determined the rank of the expression by now. If
3125 not, that's bad news. */
3126 gcc_assert (loop->dimen != 0);
3128 /* Loop over all the SS in the chain. */
3129 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3131 if (ss->expr && ss->expr->shape && !ss->shape)
3132 ss->shape = ss->expr->shape;
3136 case GFC_SS_SECTION:
3137 /* Get the descriptor for the array. */
3138 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3140 for (n = 0; n < ss->data.info.dimen; n++)
3141 gfc_conv_section_startstride (loop, ss, n);
3144 case GFC_SS_INTRINSIC:
3145 switch (ss->expr->value.function.isym->id)
3147 /* Fall through to supply start and stride. */
3148 case GFC_ISYM_LBOUND:
3149 case GFC_ISYM_UBOUND:
3155 case GFC_SS_CONSTRUCTOR:
3156 case GFC_SS_FUNCTION:
3157 for (n = 0; n < ss->data.info.dimen; n++)
3159 ss->data.info.start[n] = gfc_index_zero_node;
3160 ss->data.info.end[n] = gfc_index_zero_node;
3161 ss->data.info.stride[n] = gfc_index_one_node;
3170 /* The rest is just runtime bound checking. */
3171 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3174 tree lbound, ubound;
3176 tree size[GFC_MAX_DIMENSIONS];
3177 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3182 gfc_start_block (&block);
3184 for (n = 0; n < loop->dimen; n++)
3185 size[n] = NULL_TREE;
3187 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3191 if (ss->type != GFC_SS_SECTION)
3194 gfc_start_block (&inner);
3196 /* TODO: range checking for mapped dimensions. */
3197 info = &ss->data.info;
3199 /* This code only checks ranges. Elemental and vector
3200 dimensions are checked later. */
3201 for (n = 0; n < loop->dimen; n++)
3206 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3209 if (dim == info->ref->u.ar.dimen - 1
3210 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3211 || info->ref->u.ar.as->cp_was_assumed))
3212 check_upper = false;
3216 /* Zero stride is not allowed. */
3217 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3218 gfc_index_zero_node);
3219 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3220 "of array '%s'", info->dim[n]+1,
3221 ss->expr->symtree->name);
3222 gfc_trans_runtime_check (true, false, tmp, &inner,
3223 &ss->expr->where, msg);
3226 desc = ss->data.info.descriptor;
3228 /* This is the run-time equivalent of resolve.c's
3229 check_dimension(). The logical is more readable there
3230 than it is here, with all the trees. */
3231 lbound = gfc_conv_array_lbound (desc, dim);
3234 ubound = gfc_conv_array_ubound (desc, dim);
3238 /* non_zerosized is true when the selected range is not
3240 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3241 info->stride[n], gfc_index_zero_node);
3242 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3244 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3247 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3248 info->stride[n], gfc_index_zero_node);
3249 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3251 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3253 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3254 stride_pos, stride_neg);
3256 /* Check the start of the range against the lower and upper
3257 bounds of the array, if the range is not empty.
3258 If upper bound is present, include both bounds in the
3262 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3263 info->start[n], lbound);
3264 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3265 non_zerosized, tmp);
3266 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3267 info->start[n], ubound);
3268 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3269 non_zerosized, tmp2);
3270 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3271 "outside of expected range (%%ld:%%ld)",
3272 info->dim[n]+1, ss->expr->symtree->name);
3273 gfc_trans_runtime_check (true, false, tmp, &inner,
3274 &ss->expr->where, msg,
3275 fold_convert (long_integer_type_node, info->start[n]),
3276 fold_convert (long_integer_type_node, lbound),
3277 fold_convert (long_integer_type_node, ubound));
3278 gfc_trans_runtime_check (true, false, tmp2, &inner,
3279 &ss->expr->where, msg,
3280 fold_convert (long_integer_type_node, info->start[n]),
3281 fold_convert (long_integer_type_node, lbound),
3282 fold_convert (long_integer_type_node, ubound));
3287 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3288 info->start[n], lbound);
3289 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3290 non_zerosized, tmp);
3291 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3292 "below lower bound of %%ld",
3293 info->dim[n]+1, ss->expr->symtree->name);
3294 gfc_trans_runtime_check (true, false, tmp, &inner,
3295 &ss->expr->where, msg,
3296 fold_convert (long_integer_type_node, info->start[n]),
3297 fold_convert (long_integer_type_node, lbound));
3301 /* Compute the last element of the range, which is not
3302 necessarily "end" (think 0:5:3, which doesn't contain 5)
3303 and check it against both lower and upper bounds. */
3305 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3307 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3309 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3311 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3312 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3313 non_zerosized, tmp2);
3316 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3317 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3318 non_zerosized, tmp3);
3319 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3320 "outside of expected range (%%ld:%%ld)",
3321 info->dim[n]+1, ss->expr->symtree->name);
3322 gfc_trans_runtime_check (true, false, tmp2, &inner,
3323 &ss->expr->where, msg,
3324 fold_convert (long_integer_type_node, tmp),
3325 fold_convert (long_integer_type_node, ubound),
3326 fold_convert (long_integer_type_node, lbound));
3327 gfc_trans_runtime_check (true, false, tmp3, &inner,
3328 &ss->expr->where, msg,
3329 fold_convert (long_integer_type_node, tmp),
3330 fold_convert (long_integer_type_node, ubound),
3331 fold_convert (long_integer_type_node, lbound));
3336 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3337 "below lower bound of %%ld",
3338 info->dim[n]+1, ss->expr->symtree->name);
3339 gfc_trans_runtime_check (true, false, tmp2, &inner,
3340 &ss->expr->where, msg,
3341 fold_convert (long_integer_type_node, tmp),
3342 fold_convert (long_integer_type_node, lbound));
3346 /* Check the section sizes match. */
3347 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3349 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3351 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3352 gfc_index_one_node, tmp);
3353 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3354 build_int_cst (gfc_array_index_type, 0));
3355 /* We remember the size of the first section, and check all the
3356 others against this. */
3359 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3360 asprintf (&msg, "%s, size mismatch for dimension %d "
3361 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3362 info->dim[n]+1, ss->expr->symtree->name);
3363 gfc_trans_runtime_check (true, false, tmp3, &inner,
3364 &ss->expr->where, msg,
3365 fold_convert (long_integer_type_node, tmp),
3366 fold_convert (long_integer_type_node, size[n]));
3370 size[n] = gfc_evaluate_now (tmp, &inner);
3373 tmp = gfc_finish_block (&inner);
3375 /* For optional arguments, only check bounds if the argument is
3377 if (ss->expr->symtree->n.sym->attr.optional
3378 || ss->expr->symtree->n.sym->attr.not_always_present)
3379 tmp = build3_v (COND_EXPR,
3380 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3381 tmp, build_empty_stmt (input_location));
3383 gfc_add_expr_to_block (&block, tmp);
3387 tmp = gfc_finish_block (&block);
3388 gfc_add_expr_to_block (&loop->pre, tmp);
3393 /* Return true if the two SS could be aliased, i.e. both point to the same data
3395 /* TODO: resolve aliases based on frontend expressions. */
3398 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3405 lsym = lss->expr->symtree->n.sym;
3406 rsym = rss->expr->symtree->n.sym;
3407 if (gfc_symbols_could_alias (lsym, rsym))
3410 if (rsym->ts.type != BT_DERIVED
3411 && lsym->ts.type != BT_DERIVED)
3414 /* For derived types we must check all the component types. We can ignore
3415 array references as these will have the same base type as the previous
3417 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3419 if (lref->type != REF_COMPONENT)
3422 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3425 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3428 if (rref->type != REF_COMPONENT)
3431 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3436 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3438 if (rref->type != REF_COMPONENT)
3441 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3449 /* Resolve array data dependencies. Creates a temporary if required. */
3450 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3454 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3462 loop->temp_ss = NULL;
3464 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3466 if (ss->type != GFC_SS_SECTION)
3469 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3471 if (gfc_could_be_alias (dest, ss)
3472 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3480 lref = dest->expr->ref;
3481 rref = ss->expr->ref;
3483 nDepend = gfc_dep_resolver (lref, rref);
3487 /* TODO : loop shifting. */
3490 /* Mark the dimensions for LOOP SHIFTING */
3491 for (n = 0; n < loop->dimen; n++)
3493 int dim = dest->data.info.dim[n];
3495 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3497 else if (! gfc_is_same_range (&lref->u.ar,
3498 &rref->u.ar, dim, 0))
3502 /* Put all the dimensions with dependencies in the
3505 for (n = 0; n < loop->dimen; n++)
3507 gcc_assert (loop->order[n] == n);
3509 loop->order[dim++] = n;
3511 for (n = 0; n < loop->dimen; n++)
3514 loop->order[dim++] = n;
3517 gcc_assert (dim == loop->dimen);
3526 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3527 if (GFC_ARRAY_TYPE_P (base_type)
3528 || GFC_DESCRIPTOR_TYPE_P (base_type))
3529 base_type = gfc_get_element_type (base_type);
3530 loop->temp_ss = gfc_get_ss ();
3531 loop->temp_ss->type = GFC_SS_TEMP;
3532 loop->temp_ss->data.temp.type = base_type;
3533 loop->temp_ss->string_length = dest->string_length;
3534 loop->temp_ss->data.temp.dimen = loop->dimen;
3535 loop->temp_ss->next = gfc_ss_terminator;
3536 gfc_add_ss_to_loop (loop, loop->temp_ss);
3539 loop->temp_ss = NULL;
3543 /* Initialize the scalarization loop. Creates the loop variables. Determines
3544 the range of the loop variables. Creates a temporary if required.
3545 Calculates how to transform from loop variables to array indices for each
3546 expression. Also generates code for scalar expressions which have been
3547 moved outside the loop. */
3550 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3554 gfc_ss_info *specinfo;
3557 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3558 bool dynamic[GFC_MAX_DIMENSIONS];
3564 for (n = 0; n < loop->dimen; n++)
3568 /* We use one SS term, and use that to determine the bounds of the
3569 loop for this dimension. We try to pick the simplest term. */
3570 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3574 /* The frontend has worked out the size for us. */
3575 if (!loopspec[n] || !loopspec[n]->shape
3576 || !integer_zerop (loopspec[n]->data.info.start[n]))
3577 /* Prefer zero-based descriptors if possible. */
3582 if (ss->type == GFC_SS_CONSTRUCTOR)
3584 /* An unknown size constructor will always be rank one.
3585 Higher rank constructors will either have known shape,
3586 or still be wrapped in a call to reshape. */
3587 gcc_assert (loop->dimen == 1);
3589 /* Always prefer to use the constructor bounds if the size
3590 can be determined at compile time. Prefer not to otherwise,
3591 since the general case involves realloc, and it's better to
3592 avoid that overhead if possible. */
3593 c = ss->expr->value.constructor;
3594 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3595 if (!dynamic[n] || !loopspec[n])
3600 /* TODO: Pick the best bound if we have a choice between a
3601 function and something else. */
3602 if (ss->type == GFC_SS_FUNCTION)
3608 if (ss->type != GFC_SS_SECTION)
3612 specinfo = &loopspec[n]->data.info;
3615 info = &ss->data.info;
3619 /* Criteria for choosing a loop specifier (most important first):
3620 doesn't need realloc
3626 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3628 else if (integer_onep (info->stride[n])
3629 && !integer_onep (specinfo->stride[n]))
3631 else if (INTEGER_CST_P (info->stride[n])
3632 && !INTEGER_CST_P (specinfo->stride[n]))
3634 else if (INTEGER_CST_P (info->start[n])
3635 && !INTEGER_CST_P (specinfo->start[n]))
3637 /* We don't work out the upper bound.
3638 else if (INTEGER_CST_P (info->finish[n])
3639 && ! INTEGER_CST_P (specinfo->finish[n]))
3640 loopspec[n] = ss; */
3643 /* We should have found the scalarization loop specifier. If not,
3645 gcc_assert (loopspec[n]);
3647 info = &loopspec[n]->data.info;
3649 /* Set the extents of this range. */
3650 cshape = loopspec[n]->shape;
3651 if (cshape && INTEGER_CST_P (info->start[n])
3652 && INTEGER_CST_P (info->stride[n]))
3654 loop->from[n] = info->start[n];
3655 mpz_set (i, cshape[n]);
3656 mpz_sub_ui (i, i, 1);
3657 /* To = from + (size - 1) * stride. */
3658 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3659 if (!integer_onep (info->stride[n]))
3660 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3661 tmp, info->stride[n]);
3662 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3663 loop->from[n], tmp);
3667 loop->from[n] = info->start[n];
3668 switch (loopspec[n]->type)
3670 case GFC_SS_CONSTRUCTOR:
3671 /* The upper bound is calculated when we expand the
3673 gcc_assert (loop->to[n] == NULL_TREE);
3676 case GFC_SS_SECTION:
3677 /* Use the end expression if it exists and is not constant,
3678 so that it is only evaluated once. */
3679 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3680 loop->to[n] = info->end[n];
3682 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3686 case GFC_SS_FUNCTION:
3687 /* The loop bound will be set when we generate the call. */
3688 gcc_assert (loop->to[n] == NULL_TREE);
3696 /* Transform everything so we have a simple incrementing variable. */
3697 if (integer_onep (info->stride[n]))
3698 info->delta[n] = gfc_index_zero_node;
3701 /* Set the delta for this section. */
3702 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3703 /* Number of iterations is (end - start + step) / step.
3704 with start = 0, this simplifies to
3706 for (i = 0; i<=last; i++){...}; */
3707 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3708 loop->to[n], loop->from[n]);
3709 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3710 tmp, info->stride[n]);
3711 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3712 build_int_cst (gfc_array_index_type, -1));
3713 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3714 /* Make the loop variable start at 0. */
3715 loop->from[n] = gfc_index_zero_node;
3719 /* Add all the scalar code that can be taken out of the loops.
3720 This may include calculating the loop bounds, so do it before
3721 allocating the temporary. */
3722 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3724 /* If we want a temporary then create it. */
3725 if (loop->temp_ss != NULL)
3727 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3729 /* Make absolutely sure that this is a complete type. */
3730 if (loop->temp_ss->string_length)
3731 loop->temp_ss->data.temp.type
3732 = gfc_get_character_type_len_for_eltype
3733 (TREE_TYPE (loop->temp_ss->data.temp.type),
3734 loop->temp_ss->string_length);
3736 tmp = loop->temp_ss->data.temp.type;
3737 n = loop->temp_ss->data.temp.dimen;
3738 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3739 loop->temp_ss->type = GFC_SS_SECTION;
3740 loop->temp_ss->data.info.dimen = n;
3741 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3742 &loop->temp_ss->data.info, tmp, NULL_TREE,
3743 false, true, false, where);
3746 for (n = 0; n < loop->temp_dim; n++)
3747 loopspec[loop->order[n]] = NULL;
3751 /* For array parameters we don't have loop variables, so don't calculate the
3753 if (loop->array_parameter)
3756 /* Calculate the translation from loop variables to array indices. */
3757 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3759 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3760 && ss->type != GFC_SS_CONSTRUCTOR)
3764 info = &ss->data.info;
3766 for (n = 0; n < info->dimen; n++)
3768 /* If we are specifying the range the delta is already set. */
3769 if (loopspec[n] != ss)
3771 /* Calculate the offset relative to the loop variable.
3772 First multiply by the stride. */
3773 tmp = loop->from[n];
3774 if (!integer_onep (info->stride[n]))
3775 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3776 tmp, info->stride[n]);
3778 /* Then subtract this from our starting value. */
3779 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3780 info->start[n], tmp);
3782 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3789 /* Fills in an array descriptor, and returns the size of the array. The size
3790 will be a simple_val, ie a variable or a constant. Also calculates the
3791 offset of the base. Returns the size of the array.
3795 for (n = 0; n < rank; n++)
3797 a.lbound[n] = specified_lower_bound;
3798 offset = offset + a.lbond[n] * stride;
3800 a.ubound[n] = specified_upper_bound;
3801 a.stride[n] = stride;
3802 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3803 stride = stride * size;
3810 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3811 gfc_expr ** lower, gfc_expr ** upper,
3812 stmtblock_t * pblock)
3824 stmtblock_t thenblock;
3825 stmtblock_t elseblock;
3830 type = TREE_TYPE (descriptor);
3832 stride = gfc_index_one_node;
3833 offset = gfc_index_zero_node;
3835 /* Set the dtype. */
3836 tmp = gfc_conv_descriptor_dtype (descriptor);
3837 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3839 or_expr = NULL_TREE;
3841 for (n = 0; n < rank; n++)
3843 /* We have 3 possibilities for determining the size of the array:
3844 lower == NULL => lbound = 1, ubound = upper[n]
3845 upper[n] = NULL => lbound = 1, ubound = lower[n]
3846 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3849 /* Set lower bound. */
3850 gfc_init_se (&se, NULL);
3852 se.expr = gfc_index_one_node;
3855 gcc_assert (lower[n]);
3858 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3859 gfc_add_block_to_block (pblock, &se.pre);
3863 se.expr = gfc_index_one_node;
3867 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3870 /* Work out the offset for this component. */
3871 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3872 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3874 /* Start the calculation for the size of this dimension. */
3875 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3876 gfc_index_one_node, se.expr);
3878 /* Set upper bound. */
3879 gfc_init_se (&se, NULL);
3880 gcc_assert (ubound);
3881 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3882 gfc_add_block_to_block (pblock, &se.pre);
3884 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3886 /* Store the stride. */
3887 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3889 /* Calculate the size of this dimension. */
3890 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3892 /* Check whether the size for this dimension is negative. */
3893 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3894 gfc_index_zero_node);
3898 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3900 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3901 gfc_index_zero_node, size);
3903 /* Multiply the stride by the number of elements in this dimension. */
3904 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3905 stride = gfc_evaluate_now (stride, pblock);
3908 /* The stride is the number of elements in the array, so multiply by the
3909 size of an element to get the total size. */
3910 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3911 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3912 fold_convert (gfc_array_index_type, tmp));
3914 if (poffset != NULL)
3916 offset = gfc_evaluate_now (offset, pblock);
3920 if (integer_zerop (or_expr))
3922 if (integer_onep (or_expr))
3923 return gfc_index_zero_node;
3925 var = gfc_create_var (TREE_TYPE (size), "size");
3926 gfc_start_block (&thenblock);
3927 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3928 thencase = gfc_finish_block (&thenblock);
3930 gfc_start_block (&elseblock);
3931 gfc_add_modify (&elseblock, var, size);
3932 elsecase = gfc_finish_block (&elseblock);
3934 tmp = gfc_evaluate_now (or_expr, pblock);
3935 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3936 gfc_add_expr_to_block (pblock, tmp);
3942 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3943 the work for an ALLOCATE statement. */
3947 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3955 gfc_ref *ref, *prev_ref = NULL;
3956 bool allocatable_array;
3960 /* Find the last reference in the chain. */
3961 while (ref && ref->next != NULL)
3963 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3968 if (ref == NULL || ref->type != REF_ARRAY)
3972 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3974 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3976 /* Figure out the size of the array. */
3977 switch (ref->u.ar.type)
3981 upper = ref->u.ar.start;
3985 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3987 lower = ref->u.ar.as->lower;
3988 upper = ref->u.ar.as->upper;
3992 lower = ref->u.ar.start;
3993 upper = ref->u.ar.end;
4001 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
4002 lower, upper, &se->pre);
4004 /* Allocate memory to store the data. */
4005 pointer = gfc_conv_descriptor_data_get (se->expr);
4006 STRIP_NOPS (pointer);
4008 /* The allocate_array variants take the old pointer as first argument. */
4009 if (allocatable_array)
4010 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4012 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4013 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4014 gfc_add_expr_to_block (&se->pre, tmp);
4016 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4018 if (expr->ts.type == BT_DERIVED
4019 && expr->ts.u.derived->attr.alloc_comp)
4021 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4022 ref->u.ar.as->rank);
4023 gfc_add_expr_to_block (&se->pre, tmp);
4030 /* Deallocate an array variable. Also used when an allocated variable goes
4035 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4041 gfc_start_block (&block);
4042 /* Get a pointer to the data. */
4043 var = gfc_conv_descriptor_data_get (descriptor);
4046 /* Parameter is the address of the data component. */
4047 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4048 gfc_add_expr_to_block (&block, tmp);
4050 /* Zero the data pointer. */
4051 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4052 var, build_int_cst (TREE_TYPE (var), 0));
4053 gfc_add_expr_to_block (&block, tmp);
4055 return gfc_finish_block (&block);
4059 /* Create an array constructor from an initialization expression.
4060 We assume the frontend already did any expansions and conversions. */
4063 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4070 unsigned HOST_WIDE_INT lo;
4072 VEC(constructor_elt,gc) *v = NULL;
4074 switch (expr->expr_type)
4077 case EXPR_STRUCTURE:
4078 /* A single scalar or derived type value. Create an array with all
4079 elements equal to that value. */
4080 gfc_init_se (&se, NULL);
4082 if (expr->expr_type == EXPR_CONSTANT)
4083 gfc_conv_constant (&se, expr);
4085 gfc_conv_structure (&se, expr, 1);
4087 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4088 gcc_assert (tmp && INTEGER_CST_P (tmp));
4089 hi = TREE_INT_CST_HIGH (tmp);
4090 lo = TREE_INT_CST_LOW (tmp);
4094 /* This will probably eat buckets of memory for large arrays. */
4095 while (hi != 0 || lo != 0)
4097 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4105 /* Create a vector of all the elements. */
4106 for (c = expr->value.constructor; c; c = c->next)
4110 /* Problems occur when we get something like
4111 integer :: a(lots) = (/(i, i=1, lots)/) */
4112 gfc_error_now ("The number of elements in the array constructor "
4113 "at %L requires an increase of the allowed %d "
4114 "upper limit. See -fmax-array-constructor "
4115 "option", &expr->where,
4116 gfc_option.flag_max_array_constructor);
4119 if (mpz_cmp_si (c->n.offset, 0) != 0)
4120 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4124 if (mpz_cmp_si (c->repeat, 0) != 0)
4128 mpz_set (maxval, c->repeat);
4129 mpz_add (maxval, c->n.offset, maxval);
4130 mpz_sub_ui (maxval, maxval, 1);
4131 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4132 if (mpz_cmp_si (c->n.offset, 0) != 0)
4134 mpz_add_ui (maxval, c->n.offset, 1);
4135 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4138 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4140 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4146 gfc_init_se (&se, NULL);
4147 switch (c->expr->expr_type)
4150 gfc_conv_constant (&se, c->expr);
4151 if (range == NULL_TREE)
4152 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4155 if (index != NULL_TREE)
4156 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4157 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4161 case EXPR_STRUCTURE:
4162 gfc_conv_structure (&se, c->expr, 1);
4163 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4168 /* Catch those occasional beasts that do not simplify
4169 for one reason or another, assuming that if they are
4170 standard defying the frontend will catch them. */
4171 gfc_conv_expr (&se, c->expr);
4172 if (range == NULL_TREE)
4173 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4176 if (index != NULL_TREE)
4177 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4178 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4186 return gfc_build_null_descriptor (type);
4192 /* Create a constructor from the list of elements. */
4193 tmp = build_constructor (type, v);
4194 TREE_CONSTANT (tmp) = 1;
4199 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4200 returns the size (in elements) of the array. */
4203 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4204 stmtblock_t * pblock)
4219 size = gfc_index_one_node;
4220 offset = gfc_index_zero_node;
4221 for (dim = 0; dim < as->rank; dim++)
4223 /* Evaluate non-constant array bound expressions. */
4224 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4225 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4227 gfc_init_se (&se, NULL);
4228 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4229 gfc_add_block_to_block (pblock, &se.pre);
4230 gfc_add_modify (pblock, lbound, se.expr);
4232 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4233 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4235 gfc_init_se (&se, NULL);
4236 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4237 gfc_add_block_to_block (pblock, &se.pre);
4238 gfc_add_modify (pblock, ubound, se.expr);
4240 /* The offset of this dimension. offset = offset - lbound * stride. */
4241 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4242 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4244 /* The size of this dimension, and the stride of the next. */
4245 if (dim + 1 < as->rank)
4246 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4248 stride = GFC_TYPE_ARRAY_SIZE (type);
4250 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4252 /* Calculate stride = size * (ubound + 1 - lbound). */
4253 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4254 gfc_index_one_node, lbound);
4255 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4256 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4258 gfc_add_modify (pblock, stride, tmp);
4260 stride = gfc_evaluate_now (tmp, pblock);
4262 /* Make sure that negative size arrays are translated
4263 to being zero size. */
4264 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4265 stride, gfc_index_zero_node);
4266 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4267 stride, gfc_index_zero_node);
4268 gfc_add_modify (pblock, stride, tmp);
4274 gfc_trans_vla_type_sizes (sym, pblock);
4281 /* Generate code to initialize/allocate an array variable. */
4284 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4293 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4295 /* Do nothing for USEd variables. */
4296 if (sym->attr.use_assoc)
4299 type = TREE_TYPE (decl);
4300 gcc_assert (GFC_ARRAY_TYPE_P (type));
4301 onstack = TREE_CODE (type) != POINTER_TYPE;
4303 gfc_start_block (&block);
4305 /* Evaluate character string length. */
4306 if (sym->ts.type == BT_CHARACTER
4307 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4309 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4311 gfc_trans_vla_type_sizes (sym, &block);
4313 /* Emit a DECL_EXPR for this variable, which will cause the
4314 gimplifier to allocate storage, and all that good stuff. */
4315 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4316 gfc_add_expr_to_block (&block, tmp);
4321 gfc_add_expr_to_block (&block, fnbody);
4322 return gfc_finish_block (&block);
4325 type = TREE_TYPE (type);
4327 gcc_assert (!sym->attr.use_assoc);
4328 gcc_assert (!TREE_STATIC (decl));
4329 gcc_assert (!sym->module);
4331 if (sym->ts.type == BT_CHARACTER
4332 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4333 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4335 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4337 /* Don't actually allocate space for Cray Pointees. */
4338 if (sym->attr.cray_pointee)
4340 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4341 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4342 gfc_add_expr_to_block (&block, fnbody);
4343 return gfc_finish_block (&block);
4346 /* The size is the number of elements in the array, so multiply by the
4347 size of an element to get the total size. */
4348 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4349 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4350 fold_convert (gfc_array_index_type, tmp));
4352 /* Allocate memory to hold the data. */
4353 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4354 gfc_add_modify (&block, decl, tmp);
4356 /* Set offset of the array. */
4357 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4358 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4361 /* Automatic arrays should not have initializers. */
4362 gcc_assert (!sym->value);
4364 gfc_add_expr_to_block (&block, fnbody);
4366 /* Free the temporary. */
4367 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4368 gfc_add_expr_to_block (&block, tmp);
4370 return gfc_finish_block (&block);
4374 /* Generate entry and exit code for g77 calling convention arrays. */
4377 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4387 gfc_get_backend_locus (&loc);
4388 gfc_set_backend_locus (&sym->declared_at);
4390 /* Descriptor type. */
4391 parm = sym->backend_decl;
4392 type = TREE_TYPE (parm);
4393 gcc_assert (GFC_ARRAY_TYPE_P (type));
4395 gfc_start_block (&block);
4397 if (sym->ts.type == BT_CHARACTER
4398 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4399 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4401 /* Evaluate the bounds of the array. */
4402 gfc_trans_array_bounds (type, sym, &offset, &block);
4404 /* Set the offset. */
4405 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4406 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4408 /* Set the pointer itself if we aren't using the parameter directly. */
4409 if (TREE_CODE (parm) != PARM_DECL)
4411 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4412 gfc_add_modify (&block, parm, tmp);
4414 stmt = gfc_finish_block (&block);
4416 gfc_set_backend_locus (&loc);
4418 gfc_start_block (&block);
4420 /* Add the initialization code to the start of the function. */
4422 if (sym->attr.optional || sym->attr.not_always_present)
4424 tmp = gfc_conv_expr_present (sym);
4425 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4428 gfc_add_expr_to_block (&block, stmt);
4429 gfc_add_expr_to_block (&block, body);
4431 return gfc_finish_block (&block);
4435 /* Modify the descriptor of an array parameter so that it has the
4436 correct lower bound. Also move the upper bound accordingly.
4437 If the array is not packed, it will be copied into a temporary.
4438 For each dimension we set the new lower and upper bounds. Then we copy the
4439 stride and calculate the offset for this dimension. We also work out
4440 what the stride of a packed array would be, and see it the two match.
4441 If the array need repacking, we set the stride to the values we just
4442 calculated, recalculate the offset and copy the array data.
4443 Code is also added to copy the data back at the end of the function.
4447 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4454 stmtblock_t cleanup;
4462 tree stride, stride2;
4472 /* Do nothing for pointer and allocatable arrays. */
4473 if (sym->attr.pointer || sym->attr.allocatable)
4476 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4477 return gfc_trans_g77_array (sym, body);
4479 gfc_get_backend_locus (&loc);
4480 gfc_set_backend_locus (&sym->declared_at);
4482 /* Descriptor type. */
4483 type = TREE_TYPE (tmpdesc);
4484 gcc_assert (GFC_ARRAY_TYPE_P (type));
4485 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4486 dumdesc = build_fold_indirect_ref_loc (input_location,
4488 gfc_start_block (&block);
4490 if (sym->ts.type == BT_CHARACTER
4491 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4492 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4494 checkparm = (sym->as->type == AS_EXPLICIT
4495 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4497 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4498 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4500 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4502 /* For non-constant shape arrays we only check if the first dimension
4503 is contiguous. Repacking higher dimensions wouldn't gain us
4504 anything as we still don't know the array stride. */
4505 partial = gfc_create_var (boolean_type_node, "partial");
4506 TREE_USED (partial) = 1;
4507 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4508 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4509 gfc_add_modify (&block, partial, tmp);
4513 partial = NULL_TREE;
4516 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4517 here, however I think it does the right thing. */
4520 /* Set the first stride. */
4521 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4522 stride = gfc_evaluate_now (stride, &block);
4524 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4525 stride, gfc_index_zero_node);
4526 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4527 gfc_index_one_node, stride);
4528 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4529 gfc_add_modify (&block, stride, tmp);
4531 /* Allow the user to disable array repacking. */
4532 stmt_unpacked = NULL_TREE;
4536 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4537 /* A library call to repack the array if necessary. */
4538 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4539 stmt_unpacked = build_call_expr_loc (input_location,
4540 gfor_fndecl_in_pack, 1, tmp);
4542 stride = gfc_index_one_node;
4544 if (gfc_option.warn_array_temp)
4545 gfc_warning ("Creating array temporary at %L", &loc);
4548 /* This is for the case where the array data is used directly without
4549 calling the repack function. */
4550 if (no_repack || partial != NULL_TREE)
4551 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4553 stmt_packed = NULL_TREE;
4555 /* Assign the data pointer. */
4556 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4558 /* Don't repack unknown shape arrays when the first stride is 1. */
4559 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4560 partial, stmt_packed, stmt_unpacked);
4563 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4564 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4566 offset = gfc_index_zero_node;
4567 size = gfc_index_one_node;
4569 /* Evaluate the bounds of the array. */
4570 for (n = 0; n < sym->as->rank; n++)
4572 if (checkparm || !sym->as->upper[n])
4574 /* Get the bounds of the actual parameter. */
4575 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4576 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4580 dubound = NULL_TREE;
4581 dlbound = NULL_TREE;
4584 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4585 if (!INTEGER_CST_P (lbound))
4587 gfc_init_se (&se, NULL);
4588 gfc_conv_expr_type (&se, sym->as->lower[n],
4589 gfc_array_index_type);
4590 gfc_add_block_to_block (&block, &se.pre);
4591 gfc_add_modify (&block, lbound, se.expr);
4594 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4595 /* Set the desired upper bound. */
4596 if (sym->as->upper[n])
4598 /* We know what we want the upper bound to be. */
4599 if (!INTEGER_CST_P (ubound))
4601 gfc_init_se (&se, NULL);
4602 gfc_conv_expr_type (&se, sym->as->upper[n],
4603 gfc_array_index_type);
4604 gfc_add_block_to_block (&block, &se.pre);
4605 gfc_add_modify (&block, ubound, se.expr);
4608 /* Check the sizes match. */
4611 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4614 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4616 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4618 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4619 asprintf (&msg, "%s for dimension %d of array '%s'",
4620 gfc_msg_bounds, n+1, sym->name);
4621 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4627 /* For assumed shape arrays move the upper bound by the same amount
4628 as the lower bound. */
4629 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4631 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4632 gfc_add_modify (&block, ubound, tmp);
4634 /* The offset of this dimension. offset = offset - lbound * stride. */
4635 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4636 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4638 /* The size of this dimension, and the stride of the next. */
4639 if (n + 1 < sym->as->rank)
4641 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4643 if (no_repack || partial != NULL_TREE)
4646 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4649 /* Figure out the stride if not a known constant. */
4650 if (!INTEGER_CST_P (stride))
4653 stmt_packed = NULL_TREE;
4656 /* Calculate stride = size * (ubound + 1 - lbound). */
4657 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4658 gfc_index_one_node, lbound);
4659 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4661 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4666 /* Assign the stride. */
4667 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4668 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4669 stmt_unpacked, stmt_packed);
4671 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4672 gfc_add_modify (&block, stride, tmp);
4677 stride = GFC_TYPE_ARRAY_SIZE (type);
4679 if (stride && !INTEGER_CST_P (stride))
4681 /* Calculate size = stride * (ubound + 1 - lbound). */
4682 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4683 gfc_index_one_node, lbound);
4684 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4686 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4687 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4688 gfc_add_modify (&block, stride, tmp);
4693 /* Set the offset. */
4694 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4695 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4697 gfc_trans_vla_type_sizes (sym, &block);
4699 stmt = gfc_finish_block (&block);
4701 gfc_start_block (&block);
4703 /* Only do the entry/initialization code if the arg is present. */
4704 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4705 optional_arg = (sym->attr.optional
4706 || (sym->ns->proc_name->attr.entry_master
4707 && sym->attr.dummy));
4710 tmp = gfc_conv_expr_present (sym);
4711 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4713 gfc_add_expr_to_block (&block, stmt);
4715 /* Add the main function body. */
4716 gfc_add_expr_to_block (&block, body);
4721 gfc_start_block (&cleanup);
4723 if (sym->attr.intent != INTENT_IN)
4725 /* Copy the data back. */
4726 tmp = build_call_expr_loc (input_location,
4727 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4728 gfc_add_expr_to_block (&cleanup, tmp);
4731 /* Free the temporary. */
4732 tmp = gfc_call_free (tmpdesc);
4733 gfc_add_expr_to_block (&cleanup, tmp);
4735 stmt = gfc_finish_block (&cleanup);
4737 /* Only do the cleanup if the array was repacked. */
4738 tmp = build_fold_indirect_ref_loc (input_location,
4740 tmp = gfc_conv_descriptor_data_get (tmp);
4741 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4742 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4746 tmp = gfc_conv_expr_present (sym);
4747 stmt = build3_v (COND_EXPR, tmp, stmt,
4748 build_empty_stmt (input_location));
4750 gfc_add_expr_to_block (&block, stmt);
4752 /* We don't need to free any memory allocated by internal_pack as it will
4753 be freed at the end of the function by pop_context. */
4754 return gfc_finish_block (&block);
4758 /* Calculate the overall offset, including subreferences. */
4760 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4761 bool subref, gfc_expr *expr)
4771 /* If offset is NULL and this is not a subreferenced array, there is
4773 if (offset == NULL_TREE)
4776 offset = gfc_index_zero_node;
4781 tmp = gfc_conv_array_data (desc);
4782 tmp = build_fold_indirect_ref_loc (input_location,
4784 tmp = gfc_build_array_ref (tmp, offset, NULL);
4786 /* Offset the data pointer for pointer assignments from arrays with
4787 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4790 /* Go past the array reference. */
4791 for (ref = expr->ref; ref; ref = ref->next)
4792 if (ref->type == REF_ARRAY &&
4793 ref->u.ar.type != AR_ELEMENT)
4799 /* Calculate the offset for each subsequent subreference. */
4800 for (; ref; ref = ref->next)
4805 field = ref->u.c.component->backend_decl;
4806 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4807 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4808 tmp, field, NULL_TREE);
4812 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4813 gfc_init_se (&start, NULL);
4814 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4815 gfc_add_block_to_block (block, &start.pre);
4816 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4820 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4821 && ref->u.ar.type == AR_ELEMENT);
4823 /* TODO - Add bounds checking. */
4824 stride = gfc_index_one_node;
4825 index = gfc_index_zero_node;
4826 for (n = 0; n < ref->u.ar.dimen; n++)
4831 /* Update the index. */
4832 gfc_init_se (&start, NULL);
4833 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4834 itmp = gfc_evaluate_now (start.expr, block);
4835 gfc_init_se (&start, NULL);
4836 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4837 jtmp = gfc_evaluate_now (start.expr, block);
4838 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4839 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4840 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4841 index = gfc_evaluate_now (index, block);
4843 /* Update the stride. */
4844 gfc_init_se (&start, NULL);
4845 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4846 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4847 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4848 gfc_index_one_node, itmp);
4849 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4850 stride = gfc_evaluate_now (stride, block);
4853 /* Apply the index to obtain the array element. */
4854 tmp = gfc_build_array_ref (tmp, index, NULL);
4864 /* Set the target data pointer. */
4865 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4866 gfc_conv_descriptor_data_set (block, parm, offset);
4870 /* gfc_conv_expr_descriptor needs the string length an expression
4871 so that the size of the temporary can be obtained. This is done
4872 by adding up the string lengths of all the elements in the
4873 expression. Function with non-constant expressions have their
4874 string lengths mapped onto the actual arguments using the
4875 interface mapping machinery in trans-expr.c. */
4877 get_array_charlen (gfc_expr *expr, gfc_se *se)
4879 gfc_interface_mapping mapping;
4880 gfc_formal_arglist *formal;
4881 gfc_actual_arglist *arg;
4884 if (expr->ts.u.cl->length
4885 && gfc_is_constant_expr (expr->ts.u.cl->length))
4887 if (!expr->ts.u.cl->backend_decl)
4888 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4892 switch (expr->expr_type)
4895 get_array_charlen (expr->value.op.op1, se);
4897 /* For parentheses the expression ts.u.cl is identical. */
4898 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4901 expr->ts.u.cl->backend_decl =
4902 gfc_create_var (gfc_charlen_type_node, "sln");
4904 if (expr->value.op.op2)
4906 get_array_charlen (expr->value.op.op2, se);
4908 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4910 /* Add the string lengths and assign them to the expression
4911 string length backend declaration. */
4912 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4913 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4914 expr->value.op.op1->ts.u.cl->backend_decl,
4915 expr->value.op.op2->ts.u.cl->backend_decl));
4918 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4919 expr->value.op.op1->ts.u.cl->backend_decl);
4923 if (expr->value.function.esym == NULL
4924 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4926 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4930 /* Map expressions involving the dummy arguments onto the actual
4931 argument expressions. */
4932 gfc_init_interface_mapping (&mapping);
4933 formal = expr->symtree->n.sym->formal;
4934 arg = expr->value.function.actual;
4936 /* Set se = NULL in the calls to the interface mapping, to suppress any
4938 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4943 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4946 gfc_init_se (&tse, NULL);
4948 /* Build the expression for the character length and convert it. */
4949 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
4951 gfc_add_block_to_block (&se->pre, &tse.pre);
4952 gfc_add_block_to_block (&se->post, &tse.post);
4953 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4954 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4955 build_int_cst (gfc_charlen_type_node, 0));
4956 expr->ts.u.cl->backend_decl = tse.expr;
4957 gfc_free_interface_mapping (&mapping);
4961 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4968 /* Convert an array for passing as an actual argument. Expressions and
4969 vector subscripts are evaluated and stored in a temporary, which is then
4970 passed. For whole arrays the descriptor is passed. For array sections
4971 a modified copy of the descriptor is passed, but using the original data.
4973 This function is also used for array pointer assignments, and there
4976 - se->want_pointer && !se->direct_byref
4977 EXPR is an actual argument. On exit, se->expr contains a
4978 pointer to the array descriptor.
4980 - !se->want_pointer && !se->direct_byref
4981 EXPR is an actual argument to an intrinsic function or the
4982 left-hand side of a pointer assignment. On exit, se->expr
4983 contains the descriptor for EXPR.
4985 - !se->want_pointer && se->direct_byref
4986 EXPR is the right-hand side of a pointer assignment and
4987 se->expr is the descriptor for the previously-evaluated
4988 left-hand side. The function creates an assignment from
4989 EXPR to se->expr. */
4992 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5005 bool subref_array_target = false;
5007 gcc_assert (ss != gfc_ss_terminator);
5009 /* Special case things we know we can pass easily. */
5010 switch (expr->expr_type)
5013 /* If we have a linear array section, we can pass it directly.
5014 Otherwise we need to copy it into a temporary. */
5016 /* Find the SS for the array section. */
5018 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5019 secss = secss->next;
5021 gcc_assert (secss != gfc_ss_terminator);
5022 info = &secss->data.info;
5024 /* Get the descriptor for the array. */
5025 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5026 desc = info->descriptor;
5028 subref_array_target = se->direct_byref && is_subref_array (expr);
5029 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5030 && !subref_array_target;
5034 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5036 /* Create a new descriptor if the array doesn't have one. */
5039 else if (info->ref->u.ar.type == AR_FULL)
5041 else if (se->direct_byref)
5044 full = gfc_full_array_ref_p (info->ref, NULL);
5048 if (se->direct_byref)
5050 /* Copy the descriptor for pointer assignments. */
5051 gfc_add_modify (&se->pre, se->expr, desc);
5053 /* Add any offsets from subreferences. */
5054 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5055 subref_array_target, expr);
5057 else if (se->want_pointer)
5059 /* We pass full arrays directly. This means that pointers and
5060 allocatable arrays should also work. */
5061 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5068 if (expr->ts.type == BT_CHARACTER)
5069 se->string_length = gfc_get_expr_charlen (expr);
5076 /* A transformational function return value will be a temporary
5077 array descriptor. We still need to go through the scalarizer
5078 to create the descriptor. Elemental functions ar handled as
5079 arbitrary expressions, i.e. copy to a temporary. */
5081 /* Look for the SS for this function. */
5082 while (secss != gfc_ss_terminator
5083 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5084 secss = secss->next;
5086 if (se->direct_byref)
5088 gcc_assert (secss != gfc_ss_terminator);
5090 /* For pointer assignments pass the descriptor directly. */
5092 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5093 gfc_conv_expr (se, expr);
5097 if (secss == gfc_ss_terminator)
5099 /* Elemental function. */
5101 if (expr->ts.type == BT_CHARACTER
5102 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5103 get_array_charlen (expr, se);
5109 /* Transformational function. */
5110 info = &secss->data.info;
5116 /* Constant array constructors don't need a temporary. */
5117 if (ss->type == GFC_SS_CONSTRUCTOR
5118 && expr->ts.type != BT_CHARACTER
5119 && gfc_constant_array_constructor_p (expr->value.constructor))
5122 info = &ss->data.info;
5134 /* Something complicated. Copy it into a temporary. */
5141 gfc_init_loopinfo (&loop);
5143 /* Associate the SS with the loop. */
5144 gfc_add_ss_to_loop (&loop, ss);
5146 /* Tell the scalarizer not to bother creating loop variables, etc. */
5148 loop.array_parameter = 1;
5150 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5151 gcc_assert (!se->direct_byref);
5153 /* Setup the scalarizing loops and bounds. */
5154 gfc_conv_ss_startstride (&loop);
5158 /* Tell the scalarizer to make a temporary. */
5159 loop.temp_ss = gfc_get_ss ();
5160 loop.temp_ss->type = GFC_SS_TEMP;
5161 loop.temp_ss->next = gfc_ss_terminator;
5163 if (expr->ts.type == BT_CHARACTER
5164 && !expr->ts.u.cl->backend_decl)
5165 get_array_charlen (expr, se);
5167 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5169 if (expr->ts.type == BT_CHARACTER)
5170 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5172 loop.temp_ss->string_length = NULL;
5174 se->string_length = loop.temp_ss->string_length;
5175 loop.temp_ss->data.temp.dimen = loop.dimen;
5176 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5179 gfc_conv_loop_setup (&loop, & expr->where);
5183 /* Copy into a temporary and pass that. We don't need to copy the data
5184 back because expressions and vector subscripts must be INTENT_IN. */
5185 /* TODO: Optimize passing function return values. */
5189 /* Start the copying loops. */
5190 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5191 gfc_mark_ss_chain_used (ss, 1);
5192 gfc_start_scalarized_body (&loop, &block);
5194 /* Copy each data element. */
5195 gfc_init_se (&lse, NULL);
5196 gfc_copy_loopinfo_to_se (&lse, &loop);
5197 gfc_init_se (&rse, NULL);
5198 gfc_copy_loopinfo_to_se (&rse, &loop);
5200 lse.ss = loop.temp_ss;
5203 gfc_conv_scalarized_array_ref (&lse, NULL);
5204 if (expr->ts.type == BT_CHARACTER)
5206 gfc_conv_expr (&rse, expr);
5207 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5208 rse.expr = build_fold_indirect_ref_loc (input_location,
5212 gfc_conv_expr_val (&rse, expr);
5214 gfc_add_block_to_block (&block, &rse.pre);
5215 gfc_add_block_to_block (&block, &lse.pre);
5217 lse.string_length = rse.string_length;
5218 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5219 expr->expr_type == EXPR_VARIABLE);
5220 gfc_add_expr_to_block (&block, tmp);
5222 /* Finish the copying loops. */
5223 gfc_trans_scalarizing_loops (&loop, &block);
5225 desc = loop.temp_ss->data.info.descriptor;
5227 gcc_assert (is_gimple_lvalue (desc));
5229 else if (expr->expr_type == EXPR_FUNCTION)
5231 desc = info->descriptor;
5232 se->string_length = ss->string_length;
5236 /* We pass sections without copying to a temporary. Make a new
5237 descriptor and point it at the section we want. The loop variable
5238 limits will be the limits of the section.
5239 A function may decide to repack the array to speed up access, but
5240 we're not bothered about that here. */
5249 /* Set the string_length for a character array. */
5250 if (expr->ts.type == BT_CHARACTER)
5251 se->string_length = gfc_get_expr_charlen (expr);
5253 desc = info->descriptor;
5254 gcc_assert (secss && secss != gfc_ss_terminator);
5255 if (se->direct_byref)
5257 /* For pointer assignments we fill in the destination. */
5259 parmtype = TREE_TYPE (parm);
5263 /* Otherwise make a new one. */
5264 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5265 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5266 loop.from, loop.to, 0,
5267 GFC_ARRAY_UNKNOWN, false);
5268 parm = gfc_create_var (parmtype, "parm");
5271 offset = gfc_index_zero_node;
5274 /* The following can be somewhat confusing. We have two
5275 descriptors, a new one and the original array.
5276 {parm, parmtype, dim} refer to the new one.
5277 {desc, type, n, secss, loop} refer to the original, which maybe
5278 a descriptorless array.
5279 The bounds of the scalarization are the bounds of the section.
5280 We don't have to worry about numeric overflows when calculating
5281 the offsets because all elements are within the array data. */
5283 /* Set the dtype. */
5284 tmp = gfc_conv_descriptor_dtype (parm);
5285 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5287 /* Set offset for assignments to pointer only to zero if it is not
5289 if (se->direct_byref
5290 && info->ref && info->ref->u.ar.type != AR_FULL)
5291 base = gfc_index_zero_node;
5292 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5293 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5297 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5298 for (n = 0; n < ndim; n++)
5300 stride = gfc_conv_array_stride (desc, n);
5302 /* Work out the offset. */
5304 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5306 gcc_assert (info->subscript[n]
5307 && info->subscript[n]->type == GFC_SS_SCALAR);
5308 start = info->subscript[n]->data.scalar.expr;
5312 /* Check we haven't somehow got out of sync. */
5313 gcc_assert (info->dim[dim] == n);
5315 /* Evaluate and remember the start of the section. */
5316 start = info->start[dim];
5317 stride = gfc_evaluate_now (stride, &loop.pre);
5320 tmp = gfc_conv_array_lbound (desc, n);
5321 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5323 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5324 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5327 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5329 /* For elemental dimensions, we only need the offset. */
5333 /* Vector subscripts need copying and are handled elsewhere. */
5335 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5337 /* Set the new lower bound. */
5338 from = loop.from[dim];
5341 /* If we have an array section or are assigning make sure that
5342 the lower bound is 1. References to the full
5343 array should otherwise keep the original bounds. */
5345 || info->ref->u.ar.type != AR_FULL)
5346 && !integer_onep (from))
5348 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5349 gfc_index_one_node, from);
5350 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5351 from = gfc_index_one_node;
5353 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5354 gfc_rank_cst[dim], from);
5356 /* Set the new upper bound. */
5357 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5358 gfc_rank_cst[dim], to);
5360 /* Multiply the stride by the section stride to get the
5362 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5363 stride, info->stride[dim]);
5365 if (se->direct_byref
5367 && info->ref->u.ar.type != AR_FULL)
5369 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5372 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5374 tmp = gfc_conv_array_lbound (desc, n);
5375 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5376 tmp, loop.from[dim]);
5377 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5378 tmp, gfc_conv_array_stride (desc, n));
5379 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5383 /* Store the new stride. */
5384 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5385 gfc_rank_cst[dim], stride);
5390 if (se->data_not_needed)
5391 gfc_conv_descriptor_data_set (&loop.pre, parm,
5392 gfc_index_zero_node);
5394 /* Point the data pointer at the 1st element in the section. */
5395 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5396 subref_array_target, expr);
5398 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5399 && !se->data_not_needed)
5401 /* Set the offset. */
5402 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5406 /* Only the callee knows what the correct offset it, so just set
5408 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5413 if (!se->direct_byref)
5415 /* Get a pointer to the new descriptor. */
5416 if (se->want_pointer)
5417 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5422 gfc_add_block_to_block (&se->pre, &loop.pre);
5423 gfc_add_block_to_block (&se->post, &loop.post);
5425 /* Cleanup the scalarizer. */
5426 gfc_cleanup_loop (&loop);
5429 /* Helper function for gfc_conv_array_parameter if array size needs to be
5433 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5436 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5437 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5438 else if (expr->rank > 1)
5439 *size = build_call_expr_loc (input_location,
5440 gfor_fndecl_size0, 1,
5441 gfc_build_addr_expr (NULL, desc));
5444 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5445 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5447 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5448 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5449 gfc_index_one_node);
5450 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5451 gfc_index_zero_node);
5453 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5454 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5455 fold_convert (gfc_array_index_type, elem));
5458 /* Convert an array for passing as an actual parameter. */
5459 /* TODO: Optimize passing g77 arrays. */
5462 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5463 const gfc_symbol *fsym, const char *proc_name,
5468 tree tmp = NULL_TREE;
5470 tree parent = DECL_CONTEXT (current_function_decl);
5471 bool full_array_var, this_array_result;
5475 full_array_var = (expr->expr_type == EXPR_VARIABLE
5476 && expr->ref->type == REF_ARRAY
5477 && expr->ref->u.ar.type == AR_FULL);
5478 sym = full_array_var ? expr->symtree->n.sym : NULL;
5480 /* The symbol should have an array specification. */
5481 gcc_assert (!sym || sym->as);
5483 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5485 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5486 expr->ts.u.cl->backend_decl = tmp;
5487 se->string_length = tmp;
5490 /* Is this the result of the enclosing procedure? */
5491 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5492 if (this_array_result
5493 && (sym->backend_decl != current_function_decl)
5494 && (sym->backend_decl != parent))
5495 this_array_result = false;
5497 /* Passing address of the array if it is not pointer or assumed-shape. */
5498 if (full_array_var && g77 && !this_array_result)
5500 tmp = gfc_get_symbol_decl (sym);
5502 if (sym->ts.type == BT_CHARACTER)
5503 se->string_length = sym->ts.u.cl->backend_decl;
5504 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5505 && !sym->attr.allocatable)
5507 /* Some variables are declared directly, others are declared as
5508 pointers and allocated on the heap. */
5509 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5512 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5514 array_parameter_size (tmp, expr, size);
5517 if (sym->attr.allocatable)
5519 if (sym->attr.dummy || sym->attr.result)
5521 gfc_conv_expr_descriptor (se, expr, ss);
5525 array_parameter_size (tmp, expr, size);
5526 se->expr = gfc_conv_array_data (tmp);
5531 if (this_array_result)
5533 /* Result of the enclosing function. */
5534 gfc_conv_expr_descriptor (se, expr, ss);
5536 array_parameter_size (se->expr, expr, size);
5537 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5539 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5540 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5541 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5548 /* Every other type of array. */
5549 se->want_pointer = 1;
5550 gfc_conv_expr_descriptor (se, expr, ss);
5552 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5557 /* Deallocate the allocatable components of structures that are
5559 if (expr->ts.type == BT_DERIVED
5560 && expr->ts.u.derived->attr.alloc_comp
5561 && expr->expr_type != EXPR_VARIABLE)
5563 tmp = build_fold_indirect_ref_loc (input_location,
5565 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5566 gfc_add_expr_to_block (&se->post, tmp);
5572 /* Repack the array. */
5574 if (gfc_option.warn_array_temp)
5577 gfc_warning ("Creating array temporary at %L for argument '%s'",
5578 &expr->where, fsym->name);
5580 gfc_warning ("Creating array temporary at %L", &expr->where);
5583 ptr = build_call_expr_loc (input_location,
5584 gfor_fndecl_in_pack, 1, desc);
5586 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5588 tmp = gfc_conv_expr_present (sym);
5589 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5590 fold_convert (TREE_TYPE (se->expr), ptr),
5591 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5594 ptr = gfc_evaluate_now (ptr, &se->pre);
5598 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5602 if (fsym && proc_name)
5603 asprintf (&msg, "An array temporary was created for argument "
5604 "'%s' of procedure '%s'", fsym->name, proc_name);
5606 asprintf (&msg, "An array temporary was created");
5608 tmp = build_fold_indirect_ref_loc (input_location,
5610 tmp = gfc_conv_array_data (tmp);
5611 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5612 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5614 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5615 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5616 gfc_conv_expr_present (sym), tmp);
5618 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5623 gfc_start_block (&block);
5625 /* Copy the data back. */
5626 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5628 tmp = build_call_expr_loc (input_location,
5629 gfor_fndecl_in_unpack, 2, desc, ptr);
5630 gfc_add_expr_to_block (&block, tmp);
5633 /* Free the temporary. */
5634 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5635 gfc_add_expr_to_block (&block, tmp);
5637 stmt = gfc_finish_block (&block);
5639 gfc_init_block (&block);
5640 /* Only if it was repacked. This code needs to be executed before the
5641 loop cleanup code. */
5642 tmp = build_fold_indirect_ref_loc (input_location,
5644 tmp = gfc_conv_array_data (tmp);
5645 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5646 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5648 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5649 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5650 gfc_conv_expr_present (sym), tmp);
5652 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5654 gfc_add_expr_to_block (&block, tmp);
5655 gfc_add_block_to_block (&block, &se->post);
5657 gfc_init_block (&se->post);
5658 gfc_add_block_to_block (&se->post, &block);
5663 /* Generate code to deallocate an array, if it is allocated. */
5666 gfc_trans_dealloc_allocated (tree descriptor)
5672 gfc_start_block (&block);
5674 var = gfc_conv_descriptor_data_get (descriptor);
5677 /* Call array_deallocate with an int * present in the second argument.
5678 Although it is ignored here, it's presence ensures that arrays that
5679 are already deallocated are ignored. */
5680 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5681 gfc_add_expr_to_block (&block, tmp);
5683 /* Zero the data pointer. */
5684 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5685 var, build_int_cst (TREE_TYPE (var), 0));
5686 gfc_add_expr_to_block (&block, tmp);
5688 return gfc_finish_block (&block);
5692 /* This helper function calculates the size in words of a full array. */
5695 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5700 idx = gfc_rank_cst[rank - 1];
5701 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5702 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5703 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5704 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5705 tmp, gfc_index_one_node);
5706 tmp = gfc_evaluate_now (tmp, block);
5708 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5709 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5710 return gfc_evaluate_now (tmp, block);
5714 /* Allocate dest to the same size as src, and copy src -> dest. */
5717 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5726 /* If the source is null, set the destination to null. */
5727 gfc_init_block (&block);
5728 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5729 null_data = gfc_finish_block (&block);
5731 gfc_init_block (&block);
5733 nelems = get_full_array_size (&block, src, rank);
5734 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5735 fold_convert (gfc_array_index_type,
5736 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5738 /* Allocate memory to the destination. */
5739 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5741 gfc_conv_descriptor_data_set (&block, dest, tmp);
5743 /* We know the temporary and the value will be the same length,
5744 so can use memcpy. */
5745 tmp = built_in_decls[BUILT_IN_MEMCPY];
5746 tmp = build_call_expr_loc (input_location,
5747 tmp, 3, gfc_conv_descriptor_data_get (dest),
5748 gfc_conv_descriptor_data_get (src), size);
5749 gfc_add_expr_to_block (&block, tmp);
5750 tmp = gfc_finish_block (&block);
5752 /* Null the destination if the source is null; otherwise do
5753 the allocate and copy. */
5754 null_cond = gfc_conv_descriptor_data_get (src);
5755 null_cond = convert (pvoid_type_node, null_cond);
5756 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5757 null_cond, null_pointer_node);
5758 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5762 /* Recursively traverse an object of derived type, generating code to
5763 deallocate, nullify or copy allocatable components. This is the work horse
5764 function for the functions named in this enum. */
5766 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5769 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5770 tree dest, int rank, int purpose)
5774 stmtblock_t fnblock;
5775 stmtblock_t loopbody;
5785 tree null_cond = NULL_TREE;
5787 gfc_init_block (&fnblock);
5789 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5790 decl = build_fold_indirect_ref_loc (input_location,
5793 /* If this an array of derived types with allocatable components
5794 build a loop and recursively call this function. */
5795 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5796 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5798 tmp = gfc_conv_array_data (decl);
5799 var = build_fold_indirect_ref_loc (input_location,
5802 /* Get the number of elements - 1 and set the counter. */
5803 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5805 /* Use the descriptor for an allocatable array. Since this
5806 is a full array reference, we only need the descriptor
5807 information from dimension = rank. */
5808 tmp = get_full_array_size (&fnblock, decl, rank);
5809 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5810 tmp, gfc_index_one_node);
5812 null_cond = gfc_conv_descriptor_data_get (decl);
5813 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5814 build_int_cst (TREE_TYPE (null_cond), 0));
5818 /* Otherwise use the TYPE_DOMAIN information. */
5819 tmp = array_type_nelts (TREE_TYPE (decl));
5820 tmp = fold_convert (gfc_array_index_type, tmp);
5823 /* Remember that this is, in fact, the no. of elements - 1. */
5824 nelems = gfc_evaluate_now (tmp, &fnblock);
5825 index = gfc_create_var (gfc_array_index_type, "S");
5827 /* Build the body of the loop. */
5828 gfc_init_block (&loopbody);
5830 vref = gfc_build_array_ref (var, index, NULL);
5832 if (purpose == COPY_ALLOC_COMP)
5834 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5836 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5837 gfc_add_expr_to_block (&fnblock, tmp);
5839 tmp = build_fold_indirect_ref_loc (input_location,
5840 gfc_conv_array_data (dest));
5841 dref = gfc_build_array_ref (tmp, index, NULL);
5842 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5845 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5847 gfc_add_expr_to_block (&loopbody, tmp);
5849 /* Build the loop and return. */
5850 gfc_init_loopinfo (&loop);
5852 loop.from[0] = gfc_index_zero_node;
5853 loop.loopvar[0] = index;
5854 loop.to[0] = nelems;
5855 gfc_trans_scalarizing_loops (&loop, &loopbody);
5856 gfc_add_block_to_block (&fnblock, &loop.pre);
5858 tmp = gfc_finish_block (&fnblock);
5859 if (null_cond != NULL_TREE)
5860 tmp = build3_v (COND_EXPR, null_cond, tmp,
5861 build_empty_stmt (input_location));
5866 /* Otherwise, act on the components or recursively call self to
5867 act on a chain of components. */
5868 for (c = der_type->components; c; c = c->next)
5870 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5871 && c->ts.u.derived->attr.alloc_comp;
5872 cdecl = c->backend_decl;
5873 ctype = TREE_TYPE (cdecl);
5877 case DEALLOCATE_ALLOC_COMP:
5878 /* Do not deallocate the components of ultimate pointer
5880 if (cmp_has_alloc_comps && !c->attr.pointer)
5882 comp = fold_build3 (COMPONENT_REF, ctype,
5883 decl, cdecl, NULL_TREE);
5884 rank = c->as ? c->as->rank : 0;
5885 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
5887 gfc_add_expr_to_block (&fnblock, tmp);
5890 if (c->attr.allocatable && c->attr.dimension)
5892 comp = fold_build3 (COMPONENT_REF, ctype,
5893 decl, cdecl, NULL_TREE);
5894 tmp = gfc_trans_dealloc_allocated (comp);
5895 gfc_add_expr_to_block (&fnblock, tmp);
5897 else if (c->attr.allocatable)
5899 /* Allocatable scalar components. */
5900 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5902 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
5903 gfc_add_expr_to_block (&fnblock, tmp);
5905 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
5906 build_int_cst (TREE_TYPE (comp), 0));
5907 gfc_add_expr_to_block (&fnblock, tmp);
5909 else if (c->ts.type == BT_CLASS
5910 && c->ts.u.derived->components->attr.allocatable)
5912 /* Allocatable scalar CLASS components. */
5913 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5915 /* Add reference to '$data' component. */
5916 tmp = c->ts.u.derived->components->backend_decl;
5917 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
5918 comp, tmp, NULL_TREE);
5920 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
5921 gfc_add_expr_to_block (&fnblock, tmp);
5923 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
5924 build_int_cst (TREE_TYPE (comp), 0));
5925 gfc_add_expr_to_block (&fnblock, tmp);
5929 case NULLIFY_ALLOC_COMP:
5930 if (c->attr.pointer)
5932 else if (c->attr.allocatable && c->attr.dimension)
5934 comp = fold_build3 (COMPONENT_REF, ctype,
5935 decl, cdecl, NULL_TREE);
5936 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5938 else if (c->attr.allocatable)
5940 /* Allocatable scalar components. */
5941 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5942 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
5943 build_int_cst (TREE_TYPE (comp), 0));
5944 gfc_add_expr_to_block (&fnblock, tmp);
5946 else if (c->ts.type == BT_CLASS
5947 && c->ts.u.derived->components->attr.allocatable)
5949 /* Allocatable scalar CLASS components. */
5950 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5951 /* Add reference to '$data' component. */
5952 tmp = c->ts.u.derived->components->backend_decl;
5953 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
5954 comp, tmp, NULL_TREE);
5955 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
5956 build_int_cst (TREE_TYPE (comp), 0));
5957 gfc_add_expr_to_block (&fnblock, tmp);
5959 else if (cmp_has_alloc_comps)
5961 comp = fold_build3 (COMPONENT_REF, ctype,
5962 decl, cdecl, NULL_TREE);
5963 rank = c->as ? c->as->rank : 0;
5964 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
5966 gfc_add_expr_to_block (&fnblock, tmp);
5970 case COPY_ALLOC_COMP:
5971 if (c->attr.pointer)
5974 /* We need source and destination components. */
5975 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5976 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5977 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5979 if (c->attr.allocatable && !cmp_has_alloc_comps)
5981 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5982 gfc_add_expr_to_block (&fnblock, tmp);
5985 if (cmp_has_alloc_comps)
5987 rank = c->as ? c->as->rank : 0;
5988 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5989 gfc_add_modify (&fnblock, dcmp, tmp);
5990 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
5992 gfc_add_expr_to_block (&fnblock, tmp);
6002 return gfc_finish_block (&fnblock);
6005 /* Recursively traverse an object of derived type, generating code to
6006 nullify allocatable components. */
6009 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6011 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6012 NULLIFY_ALLOC_COMP);
6016 /* Recursively traverse an object of derived type, generating code to
6017 deallocate allocatable components. */
6020 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6022 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6023 DEALLOCATE_ALLOC_COMP);
6027 /* Recursively traverse an object of derived type, generating code to
6028 copy its allocatable components. */
6031 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6033 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6037 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6038 Do likewise, recursively if necessary, with the allocatable components of
6042 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6047 stmtblock_t fnblock;
6050 bool sym_has_alloc_comp;
6052 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6053 && sym->ts.u.derived->attr.alloc_comp;
6055 /* Make sure the frontend gets these right. */
6056 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6057 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6058 "allocatable attribute or derived type without allocatable "
6061 gfc_init_block (&fnblock);
6063 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6064 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6066 if (sym->ts.type == BT_CHARACTER
6067 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6069 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6070 gfc_trans_vla_type_sizes (sym, &fnblock);
6073 /* Dummy, use associated and result variables don't need anything special. */
6074 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6076 gfc_add_expr_to_block (&fnblock, body);
6078 return gfc_finish_block (&fnblock);
6081 gfc_get_backend_locus (&loc);
6082 gfc_set_backend_locus (&sym->declared_at);
6083 descriptor = sym->backend_decl;
6085 /* Although static, derived types with default initializers and
6086 allocatable components must not be nulled wholesale; instead they
6087 are treated component by component. */
6088 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6090 /* SAVEd variables are not freed on exit. */
6091 gfc_trans_static_array_pointer (sym);
6095 /* Get the descriptor type. */
6096 type = TREE_TYPE (sym->backend_decl);
6098 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6100 if (!sym->attr.save)
6102 rank = sym->as ? sym->as->rank : 0;
6103 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6104 gfc_add_expr_to_block (&fnblock, tmp);
6107 tmp = gfc_init_default_dt (sym, NULL);
6108 gfc_add_expr_to_block (&fnblock, tmp);
6112 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6114 /* If the backend_decl is not a descriptor, we must have a pointer
6116 descriptor = build_fold_indirect_ref_loc (input_location,
6118 type = TREE_TYPE (descriptor);
6121 /* NULLIFY the data pointer. */
6122 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6123 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6125 gfc_add_expr_to_block (&fnblock, body);
6127 gfc_set_backend_locus (&loc);
6129 /* Allocatable arrays need to be freed when they go out of scope.
6130 The allocatable components of pointers must not be touched. */
6131 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6132 && !sym->attr.pointer && !sym->attr.save)
6135 rank = sym->as ? sym->as->rank : 0;
6136 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6137 gfc_add_expr_to_block (&fnblock, tmp);
6140 if (sym->attr.allocatable && sym->attr.dimension
6141 && !sym->attr.save && !sym->attr.result)
6143 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6144 gfc_add_expr_to_block (&fnblock, tmp);
6147 return gfc_finish_block (&fnblock);
6150 /************ Expression Walking Functions ******************/
6152 /* Walk a variable reference.
6154 Possible extension - multiple component subscripts.
6155 x(:,:) = foo%a(:)%b(:)
6157 forall (i=..., j=...)
6158 x(i,j) = foo%a(j)%b(i)
6160 This adds a fair amount of complexity because you need to deal with more
6161 than one ref. Maybe handle in a similar manner to vector subscripts.
6162 Maybe not worth the effort. */
6166 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6173 for (ref = expr->ref; ref; ref = ref->next)
6174 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6177 for (; ref; ref = ref->next)
6179 if (ref->type == REF_SUBSTRING)
6181 newss = gfc_get_ss ();
6182 newss->type = GFC_SS_SCALAR;
6183 newss->expr = ref->u.ss.start;
6187 newss = gfc_get_ss ();
6188 newss->type = GFC_SS_SCALAR;
6189 newss->expr = ref->u.ss.end;
6194 /* We're only interested in array sections from now on. */
6195 if (ref->type != REF_ARRAY)
6202 for (n = 0; n < ar->dimen; n++)
6204 newss = gfc_get_ss ();
6205 newss->type = GFC_SS_SCALAR;
6206 newss->expr = ar->start[n];
6213 newss = gfc_get_ss ();
6214 newss->type = GFC_SS_SECTION;
6217 newss->data.info.dimen = ar->as->rank;
6218 newss->data.info.ref = ref;
6220 /* Make sure array is the same as array(:,:), this way
6221 we don't need to special case all the time. */
6222 ar->dimen = ar->as->rank;
6223 for (n = 0; n < ar->dimen; n++)
6225 newss->data.info.dim[n] = n;
6226 ar->dimen_type[n] = DIMEN_RANGE;
6228 gcc_assert (ar->start[n] == NULL);
6229 gcc_assert (ar->end[n] == NULL);
6230 gcc_assert (ar->stride[n] == NULL);
6236 newss = gfc_get_ss ();
6237 newss->type = GFC_SS_SECTION;
6240 newss->data.info.dimen = 0;
6241 newss->data.info.ref = ref;
6243 /* We add SS chains for all the subscripts in the section. */
6244 for (n = 0; n < ar->dimen; n++)
6248 switch (ar->dimen_type[n])
6251 /* Add SS for elemental (scalar) subscripts. */
6252 gcc_assert (ar->start[n]);
6253 indexss = gfc_get_ss ();
6254 indexss->type = GFC_SS_SCALAR;
6255 indexss->expr = ar->start[n];
6256 indexss->next = gfc_ss_terminator;
6257 indexss->loop_chain = gfc_ss_terminator;
6258 newss->data.info.subscript[n] = indexss;
6262 /* We don't add anything for sections, just remember this
6263 dimension for later. */
6264 newss->data.info.dim[newss->data.info.dimen] = n;
6265 newss->data.info.dimen++;
6269 /* Create a GFC_SS_VECTOR index in which we can store
6270 the vector's descriptor. */
6271 indexss = gfc_get_ss ();
6272 indexss->type = GFC_SS_VECTOR;
6273 indexss->expr = ar->start[n];
6274 indexss->next = gfc_ss_terminator;
6275 indexss->loop_chain = gfc_ss_terminator;
6276 newss->data.info.subscript[n] = indexss;
6277 newss->data.info.dim[newss->data.info.dimen] = n;
6278 newss->data.info.dimen++;
6282 /* We should know what sort of section it is by now. */
6286 /* We should have at least one non-elemental dimension. */
6287 gcc_assert (newss->data.info.dimen > 0);
6292 /* We should know what sort of section it is by now. */
6301 /* Walk an expression operator. If only one operand of a binary expression is
6302 scalar, we must also add the scalar term to the SS chain. */
6305 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6311 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6312 if (expr->value.op.op2 == NULL)
6315 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6317 /* All operands are scalar. Pass back and let the caller deal with it. */
6321 /* All operands require scalarization. */
6322 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6325 /* One of the operands needs scalarization, the other is scalar.
6326 Create a gfc_ss for the scalar expression. */
6327 newss = gfc_get_ss ();
6328 newss->type = GFC_SS_SCALAR;
6331 /* First operand is scalar. We build the chain in reverse order, so
6332 add the scalar SS after the second operand. */
6334 while (head && head->next != ss)
6336 /* Check we haven't somehow broken the chain. */
6340 newss->expr = expr->value.op.op1;
6342 else /* head2 == head */
6344 gcc_assert (head2 == head);
6345 /* Second operand is scalar. */
6346 newss->next = head2;
6348 newss->expr = expr->value.op.op2;
6355 /* Reverse a SS chain. */
6358 gfc_reverse_ss (gfc_ss * ss)
6363 gcc_assert (ss != NULL);
6365 head = gfc_ss_terminator;
6366 while (ss != gfc_ss_terminator)
6369 /* Check we didn't somehow break the chain. */
6370 gcc_assert (next != NULL);
6380 /* Walk the arguments of an elemental function. */
6383 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6391 head = gfc_ss_terminator;
6394 for (; arg; arg = arg->next)
6399 newss = gfc_walk_subexpr (head, arg->expr);
6402 /* Scalar argument. */
6403 newss = gfc_get_ss ();
6405 newss->expr = arg->expr;
6415 while (tail->next != gfc_ss_terminator)
6422 /* If all the arguments are scalar we don't need the argument SS. */
6423 gfc_free_ss_chain (head);
6428 /* Add it onto the existing chain. */
6434 /* Walk a function call. Scalar functions are passed back, and taken out of
6435 scalarization loops. For elemental functions we walk their arguments.
6436 The result of functions returning arrays is stored in a temporary outside
6437 the loop, so that the function is only called once. Hence we do not need
6438 to walk their arguments. */
6441 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6444 gfc_intrinsic_sym *isym;
6446 gfc_component *comp = NULL;
6448 isym = expr->value.function.isym;
6450 /* Handle intrinsic functions separately. */
6452 return gfc_walk_intrinsic_function (ss, expr, isym);
6454 sym = expr->value.function.esym;
6456 sym = expr->symtree->n.sym;
6458 /* A function that returns arrays. */
6459 gfc_is_proc_ptr_comp (expr, &comp);
6460 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6461 || (comp && comp->attr.dimension))
6463 newss = gfc_get_ss ();
6464 newss->type = GFC_SS_FUNCTION;
6467 newss->data.info.dimen = expr->rank;
6471 /* Walk the parameters of an elemental function. For now we always pass
6473 if (sym->attr.elemental)
6474 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6477 /* Scalar functions are OK as these are evaluated outside the scalarization
6478 loop. Pass back and let the caller deal with it. */
6483 /* An array temporary is constructed for array constructors. */
6486 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6491 newss = gfc_get_ss ();
6492 newss->type = GFC_SS_CONSTRUCTOR;
6495 newss->data.info.dimen = expr->rank;
6496 for (n = 0; n < expr->rank; n++)
6497 newss->data.info.dim[n] = n;
6503 /* Walk an expression. Add walked expressions to the head of the SS chain.
6504 A wholly scalar expression will not be added. */
6507 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6511 switch (expr->expr_type)
6514 head = gfc_walk_variable_expr (ss, expr);
6518 head = gfc_walk_op_expr (ss, expr);
6522 head = gfc_walk_function_expr (ss, expr);
6527 case EXPR_STRUCTURE:
6528 /* Pass back and let the caller deal with it. */
6532 head = gfc_walk_array_constructor (ss, expr);
6535 case EXPR_SUBSTRING:
6536 /* Pass back and let the caller deal with it. */
6540 internal_error ("bad expression type during walk (%d)",
6547 /* Entry point for expression walking.
6548 A return value equal to the passed chain means this is
6549 a scalar expression. It is up to the caller to take whatever action is
6550 necessary to translate these. */
6553 gfc_walk_expr (gfc_expr * expr)
6557 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6558 return gfc_reverse_ss (res);