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_fatal_error ("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, bool 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;
5472 bool this_array_result;
5475 bool array_constructor;
5476 bool good_allocatable;
5477 bool ultimate_ptr_comp;
5478 bool ultimate_alloc_comp;
5483 ultimate_ptr_comp = false;
5484 ultimate_alloc_comp = false;
5485 for (ref = expr->ref; ref; ref = ref->next)
5487 if (ref->next == NULL)
5490 if (ref->type == REF_COMPONENT)
5492 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5493 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5497 full_array_var = false;
5500 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5501 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5503 sym = full_array_var ? expr->symtree->n.sym : NULL;
5505 /* The symbol should have an array specification. */
5506 gcc_assert (!sym || sym->as || ref->u.ar.as);
5508 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5510 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5511 expr->ts.u.cl->backend_decl = tmp;
5512 se->string_length = tmp;
5515 /* Is this the result of the enclosing procedure? */
5516 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5517 if (this_array_result
5518 && (sym->backend_decl != current_function_decl)
5519 && (sym->backend_decl != parent))
5520 this_array_result = false;
5522 /* Passing address of the array if it is not pointer or assumed-shape. */
5523 if (full_array_var && g77 && !this_array_result)
5525 tmp = gfc_get_symbol_decl (sym);
5527 if (sym->ts.type == BT_CHARACTER)
5528 se->string_length = sym->ts.u.cl->backend_decl;
5530 if (sym->ts.type == BT_DERIVED)
5532 gfc_conv_expr_descriptor (se, expr, ss);
5533 se->expr = gfc_conv_array_data (se->expr);
5537 if (!sym->attr.pointer
5539 && sym->as->type != AS_ASSUMED_SHAPE
5540 && !sym->attr.allocatable)
5542 /* Some variables are declared directly, others are declared as
5543 pointers and allocated on the heap. */
5544 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5547 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5549 array_parameter_size (tmp, expr, size);
5553 if (sym->attr.allocatable)
5555 if (sym->attr.dummy || sym->attr.result)
5557 gfc_conv_expr_descriptor (se, expr, ss);
5561 array_parameter_size (tmp, expr, size);
5562 se->expr = gfc_conv_array_data (tmp);
5567 /* A convenient reduction in scope. */
5568 contiguous = g77 && !this_array_result && contiguous;
5570 /* There is no need to pack and unpack the array, if it is contiguous
5571 and not deferred or assumed shape. */
5572 no_pack = ((sym && sym->as
5573 && !sym->attr.pointer
5574 && sym->as->type != AS_DEFERRED
5575 && sym->as->type != AS_ASSUMED_SHAPE)
5577 (ref && ref->u.ar.as
5578 && ref->u.ar.as->type != AS_DEFERRED
5579 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
5581 no_pack = contiguous && no_pack;
5583 /* Array constructors are always contiguous and do not need packing. */
5584 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5586 /* Same is true of contiguous sections from allocatable variables. */
5587 good_allocatable = contiguous
5589 && expr->symtree->n.sym->attr.allocatable;
5591 /* Or ultimate allocatable components. */
5592 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5594 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5596 gfc_conv_expr_descriptor (se, expr, ss);
5597 if (expr->ts.type == BT_CHARACTER)
5598 se->string_length = expr->ts.u.cl->backend_decl;
5600 array_parameter_size (se->expr, expr, size);
5601 se->expr = gfc_conv_array_data (se->expr);
5605 if (this_array_result)
5607 /* Result of the enclosing function. */
5608 gfc_conv_expr_descriptor (se, expr, ss);
5610 array_parameter_size (se->expr, expr, size);
5611 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5613 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5614 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5615 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5622 /* Every other type of array. */
5623 se->want_pointer = 1;
5624 gfc_conv_expr_descriptor (se, expr, ss);
5626 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5631 /* Deallocate the allocatable components of structures that are
5633 if (expr->ts.type == BT_DERIVED
5634 && expr->ts.u.derived->attr.alloc_comp
5635 && expr->expr_type != EXPR_VARIABLE)
5637 tmp = build_fold_indirect_ref_loc (input_location,
5639 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5640 gfc_add_expr_to_block (&se->post, tmp);
5646 /* Repack the array. */
5647 if (gfc_option.warn_array_temp)
5650 gfc_warning ("Creating array temporary at %L for argument '%s'",
5651 &expr->where, fsym->name);
5653 gfc_warning ("Creating array temporary at %L", &expr->where);
5656 ptr = build_call_expr_loc (input_location,
5657 gfor_fndecl_in_pack, 1, desc);
5659 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5661 tmp = gfc_conv_expr_present (sym);
5662 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5663 fold_convert (TREE_TYPE (se->expr), ptr),
5664 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5667 ptr = gfc_evaluate_now (ptr, &se->pre);
5671 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5675 if (fsym && proc_name)
5676 asprintf (&msg, "An array temporary was created for argument "
5677 "'%s' of procedure '%s'", fsym->name, proc_name);
5679 asprintf (&msg, "An array temporary was created");
5681 tmp = build_fold_indirect_ref_loc (input_location,
5683 tmp = gfc_conv_array_data (tmp);
5684 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5685 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5687 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5688 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5689 gfc_conv_expr_present (sym), tmp);
5691 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5696 gfc_start_block (&block);
5698 /* Copy the data back. */
5699 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5701 tmp = build_call_expr_loc (input_location,
5702 gfor_fndecl_in_unpack, 2, desc, ptr);
5703 gfc_add_expr_to_block (&block, tmp);
5706 /* Free the temporary. */
5707 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5708 gfc_add_expr_to_block (&block, tmp);
5710 stmt = gfc_finish_block (&block);
5712 gfc_init_block (&block);
5713 /* Only if it was repacked. This code needs to be executed before the
5714 loop cleanup code. */
5715 tmp = build_fold_indirect_ref_loc (input_location,
5717 tmp = gfc_conv_array_data (tmp);
5718 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5719 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5721 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5722 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5723 gfc_conv_expr_present (sym), tmp);
5725 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5727 gfc_add_expr_to_block (&block, tmp);
5728 gfc_add_block_to_block (&block, &se->post);
5730 gfc_init_block (&se->post);
5731 gfc_add_block_to_block (&se->post, &block);
5736 /* Generate code to deallocate an array, if it is allocated. */
5739 gfc_trans_dealloc_allocated (tree descriptor)
5745 gfc_start_block (&block);
5747 var = gfc_conv_descriptor_data_get (descriptor);
5750 /* Call array_deallocate with an int * present in the second argument.
5751 Although it is ignored here, it's presence ensures that arrays that
5752 are already deallocated are ignored. */
5753 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5754 gfc_add_expr_to_block (&block, tmp);
5756 /* Zero the data pointer. */
5757 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5758 var, build_int_cst (TREE_TYPE (var), 0));
5759 gfc_add_expr_to_block (&block, tmp);
5761 return gfc_finish_block (&block);
5765 /* This helper function calculates the size in words of a full array. */
5768 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5773 idx = gfc_rank_cst[rank - 1];
5774 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5775 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5776 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5777 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5778 tmp, gfc_index_one_node);
5779 tmp = gfc_evaluate_now (tmp, block);
5781 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5782 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5783 return gfc_evaluate_now (tmp, block);
5787 /* Allocate dest to the same size as src, and copy src -> dest.
5788 If no_malloc is set, only the copy is done. */
5791 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5801 /* If the source is null, set the destination to null. Then,
5802 allocate memory to the destination. */
5803 gfc_init_block (&block);
5807 tmp = null_pointer_node;
5808 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5809 gfc_add_expr_to_block (&block, tmp);
5810 null_data = gfc_finish_block (&block);
5812 gfc_init_block (&block);
5813 size = TYPE_SIZE_UNIT (type);
5816 tmp = gfc_call_malloc (&block, type, size);
5817 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5818 fold_convert (type, tmp));
5819 gfc_add_expr_to_block (&block, tmp);
5822 tmp = built_in_decls[BUILT_IN_MEMCPY];
5823 tmp = build_call_expr_loc (input_location, tmp, 3,
5828 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5829 null_data = gfc_finish_block (&block);
5831 gfc_init_block (&block);
5832 nelems = get_full_array_size (&block, src, rank);
5833 tmp = fold_convert (gfc_array_index_type,
5834 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5835 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5838 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5839 tmp = gfc_call_malloc (&block, tmp, size);
5840 gfc_conv_descriptor_data_set (&block, dest, tmp);
5843 /* We know the temporary and the value will be the same length,
5844 so can use memcpy. */
5845 tmp = built_in_decls[BUILT_IN_MEMCPY];
5846 tmp = build_call_expr_loc (input_location,
5847 tmp, 3, gfc_conv_descriptor_data_get (dest),
5848 gfc_conv_descriptor_data_get (src), size);
5851 gfc_add_expr_to_block (&block, tmp);
5852 tmp = gfc_finish_block (&block);
5854 /* Null the destination if the source is null; otherwise do
5855 the allocate and copy. */
5859 null_cond = gfc_conv_descriptor_data_get (src);
5861 null_cond = convert (pvoid_type_node, null_cond);
5862 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5863 null_cond, null_pointer_node);
5864 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5868 /* Allocate dest to the same size as src, and copy data src -> dest. */
5871 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5873 return duplicate_allocatable(dest, src, type, rank, false);
5877 /* Copy data src -> dest. */
5880 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5882 return duplicate_allocatable(dest, src, type, rank, true);
5886 /* Recursively traverse an object of derived type, generating code to
5887 deallocate, nullify or copy allocatable components. This is the work horse
5888 function for the functions named in this enum. */
5890 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5891 COPY_ONLY_ALLOC_COMP};
5894 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5895 tree dest, int rank, int purpose)
5899 stmtblock_t fnblock;
5900 stmtblock_t loopbody;
5910 tree null_cond = NULL_TREE;
5912 gfc_init_block (&fnblock);
5914 if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
5915 decl = build_fold_indirect_ref_loc (input_location,
5918 /* If this an array of derived types with allocatable components
5919 build a loop and recursively call this function. */
5920 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5921 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5923 tmp = gfc_conv_array_data (decl);
5924 var = build_fold_indirect_ref_loc (input_location,
5927 /* Get the number of elements - 1 and set the counter. */
5928 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5930 /* Use the descriptor for an allocatable array. Since this
5931 is a full array reference, we only need the descriptor
5932 information from dimension = rank. */
5933 tmp = get_full_array_size (&fnblock, decl, rank);
5934 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5935 tmp, gfc_index_one_node);
5937 null_cond = gfc_conv_descriptor_data_get (decl);
5938 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5939 build_int_cst (TREE_TYPE (null_cond), 0));
5943 /* Otherwise use the TYPE_DOMAIN information. */
5944 tmp = array_type_nelts (TREE_TYPE (decl));
5945 tmp = fold_convert (gfc_array_index_type, tmp);
5948 /* Remember that this is, in fact, the no. of elements - 1. */
5949 nelems = gfc_evaluate_now (tmp, &fnblock);
5950 index = gfc_create_var (gfc_array_index_type, "S");
5952 /* Build the body of the loop. */
5953 gfc_init_block (&loopbody);
5955 vref = gfc_build_array_ref (var, index, NULL);
5957 if (purpose == COPY_ALLOC_COMP)
5959 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5961 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5962 gfc_add_expr_to_block (&fnblock, tmp);
5964 tmp = build_fold_indirect_ref_loc (input_location,
5965 gfc_conv_array_data (dest));
5966 dref = gfc_build_array_ref (tmp, index, NULL);
5967 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5969 else if (purpose == COPY_ONLY_ALLOC_COMP)
5971 tmp = build_fold_indirect_ref_loc (input_location,
5972 gfc_conv_array_data (dest));
5973 dref = gfc_build_array_ref (tmp, index, NULL);
5974 tmp = structure_alloc_comps (der_type, vref, dref, rank,
5978 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5980 gfc_add_expr_to_block (&loopbody, tmp);
5982 /* Build the loop and return. */
5983 gfc_init_loopinfo (&loop);
5985 loop.from[0] = gfc_index_zero_node;
5986 loop.loopvar[0] = index;
5987 loop.to[0] = nelems;
5988 gfc_trans_scalarizing_loops (&loop, &loopbody);
5989 gfc_add_block_to_block (&fnblock, &loop.pre);
5991 tmp = gfc_finish_block (&fnblock);
5992 if (null_cond != NULL_TREE)
5993 tmp = build3_v (COND_EXPR, null_cond, tmp,
5994 build_empty_stmt (input_location));
5999 /* Otherwise, act on the components or recursively call self to
6000 act on a chain of components. */
6001 for (c = der_type->components; c; c = c->next)
6003 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6004 && c->ts.u.derived->attr.alloc_comp;
6005 cdecl = c->backend_decl;
6006 ctype = TREE_TYPE (cdecl);
6010 case DEALLOCATE_ALLOC_COMP:
6011 /* Do not deallocate the components of ultimate pointer
6013 if (cmp_has_alloc_comps && !c->attr.pointer)
6015 comp = fold_build3 (COMPONENT_REF, ctype,
6016 decl, cdecl, NULL_TREE);
6017 rank = c->as ? c->as->rank : 0;
6018 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6020 gfc_add_expr_to_block (&fnblock, tmp);
6023 if (c->attr.allocatable && c->attr.dimension)
6025 comp = fold_build3 (COMPONENT_REF, ctype,
6026 decl, cdecl, NULL_TREE);
6027 tmp = gfc_trans_dealloc_allocated (comp);
6028 gfc_add_expr_to_block (&fnblock, tmp);
6030 else if (c->attr.allocatable)
6032 /* Allocatable scalar components. */
6033 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6035 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6036 gfc_add_expr_to_block (&fnblock, tmp);
6038 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6039 build_int_cst (TREE_TYPE (comp), 0));
6040 gfc_add_expr_to_block (&fnblock, tmp);
6042 else if (c->ts.type == BT_CLASS
6043 && c->ts.u.derived->components->attr.allocatable)
6045 /* Allocatable scalar CLASS components. */
6046 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6048 /* Add reference to '$data' component. */
6049 tmp = c->ts.u.derived->components->backend_decl;
6050 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6051 comp, tmp, NULL_TREE);
6053 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6054 gfc_add_expr_to_block (&fnblock, tmp);
6056 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6057 build_int_cst (TREE_TYPE (comp), 0));
6058 gfc_add_expr_to_block (&fnblock, tmp);
6062 case NULLIFY_ALLOC_COMP:
6063 if (c->attr.pointer)
6065 else if (c->attr.allocatable && c->attr.dimension)
6067 comp = fold_build3 (COMPONENT_REF, ctype,
6068 decl, cdecl, NULL_TREE);
6069 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6071 else if (c->attr.allocatable)
6073 /* Allocatable scalar components. */
6074 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6075 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6076 build_int_cst (TREE_TYPE (comp), 0));
6077 gfc_add_expr_to_block (&fnblock, tmp);
6079 else if (c->ts.type == BT_CLASS
6080 && c->ts.u.derived->components->attr.allocatable)
6082 /* Allocatable scalar CLASS components. */
6083 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6084 /* Add reference to '$data' component. */
6085 tmp = c->ts.u.derived->components->backend_decl;
6086 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6087 comp, tmp, NULL_TREE);
6088 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6089 build_int_cst (TREE_TYPE (comp), 0));
6090 gfc_add_expr_to_block (&fnblock, tmp);
6092 else if (cmp_has_alloc_comps)
6094 comp = fold_build3 (COMPONENT_REF, ctype,
6095 decl, cdecl, NULL_TREE);
6096 rank = c->as ? c->as->rank : 0;
6097 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6099 gfc_add_expr_to_block (&fnblock, tmp);
6103 case COPY_ALLOC_COMP:
6104 if (c->attr.pointer)
6107 /* We need source and destination components. */
6108 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6109 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6110 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6112 if (c->attr.allocatable && !cmp_has_alloc_comps)
6114 rank = c->as ? c->as->rank : 0;
6115 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6116 gfc_add_expr_to_block (&fnblock, tmp);
6119 if (cmp_has_alloc_comps)
6121 rank = c->as ? c->as->rank : 0;
6122 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6123 gfc_add_modify (&fnblock, dcmp, tmp);
6124 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6126 gfc_add_expr_to_block (&fnblock, tmp);
6136 return gfc_finish_block (&fnblock);
6139 /* Recursively traverse an object of derived type, generating code to
6140 nullify allocatable components. */
6143 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6145 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6146 NULLIFY_ALLOC_COMP);
6150 /* Recursively traverse an object of derived type, generating code to
6151 deallocate allocatable components. */
6154 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6156 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6157 DEALLOCATE_ALLOC_COMP);
6161 /* Recursively traverse an object of derived type, generating code to
6162 copy it and its allocatable components. */
6165 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6167 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6171 /* Recursively traverse an object of derived type, generating code to
6172 copy only its allocatable components. */
6175 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6177 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6181 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6182 Do likewise, recursively if necessary, with the allocatable components of
6186 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6191 stmtblock_t fnblock;
6194 bool sym_has_alloc_comp;
6196 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6197 && sym->ts.u.derived->attr.alloc_comp;
6199 /* Make sure the frontend gets these right. */
6200 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6201 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6202 "allocatable attribute or derived type without allocatable "
6205 gfc_init_block (&fnblock);
6207 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6208 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6210 if (sym->ts.type == BT_CHARACTER
6211 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6213 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6214 gfc_trans_vla_type_sizes (sym, &fnblock);
6217 /* Dummy, use associated and result variables don't need anything special. */
6218 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6220 gfc_add_expr_to_block (&fnblock, body);
6222 return gfc_finish_block (&fnblock);
6225 gfc_get_backend_locus (&loc);
6226 gfc_set_backend_locus (&sym->declared_at);
6227 descriptor = sym->backend_decl;
6229 /* Although static, derived types with default initializers and
6230 allocatable components must not be nulled wholesale; instead they
6231 are treated component by component. */
6232 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6234 /* SAVEd variables are not freed on exit. */
6235 gfc_trans_static_array_pointer (sym);
6239 /* Get the descriptor type. */
6240 type = TREE_TYPE (sym->backend_decl);
6242 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6244 if (!sym->attr.save)
6246 rank = sym->as ? sym->as->rank : 0;
6247 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6248 gfc_add_expr_to_block (&fnblock, tmp);
6251 tmp = gfc_init_default_dt (sym, NULL);
6252 gfc_add_expr_to_block (&fnblock, tmp);
6256 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6258 /* If the backend_decl is not a descriptor, we must have a pointer
6260 descriptor = build_fold_indirect_ref_loc (input_location,
6262 type = TREE_TYPE (descriptor);
6265 /* NULLIFY the data pointer. */
6266 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6267 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6269 gfc_add_expr_to_block (&fnblock, body);
6271 gfc_set_backend_locus (&loc);
6273 /* Allocatable arrays need to be freed when they go out of scope.
6274 The allocatable components of pointers must not be touched. */
6275 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6276 && !sym->attr.pointer && !sym->attr.save)
6279 rank = sym->as ? sym->as->rank : 0;
6280 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6281 gfc_add_expr_to_block (&fnblock, tmp);
6284 if (sym->attr.allocatable && sym->attr.dimension
6285 && !sym->attr.save && !sym->attr.result)
6287 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6288 gfc_add_expr_to_block (&fnblock, tmp);
6291 return gfc_finish_block (&fnblock);
6294 /************ Expression Walking Functions ******************/
6296 /* Walk a variable reference.
6298 Possible extension - multiple component subscripts.
6299 x(:,:) = foo%a(:)%b(:)
6301 forall (i=..., j=...)
6302 x(i,j) = foo%a(j)%b(i)
6304 This adds a fair amount of complexity because you need to deal with more
6305 than one ref. Maybe handle in a similar manner to vector subscripts.
6306 Maybe not worth the effort. */
6310 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6317 for (ref = expr->ref; ref; ref = ref->next)
6318 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6321 for (; ref; ref = ref->next)
6323 if (ref->type == REF_SUBSTRING)
6325 newss = gfc_get_ss ();
6326 newss->type = GFC_SS_SCALAR;
6327 newss->expr = ref->u.ss.start;
6331 newss = gfc_get_ss ();
6332 newss->type = GFC_SS_SCALAR;
6333 newss->expr = ref->u.ss.end;
6338 /* We're only interested in array sections from now on. */
6339 if (ref->type != REF_ARRAY)
6346 for (n = 0; n < ar->dimen; n++)
6348 newss = gfc_get_ss ();
6349 newss->type = GFC_SS_SCALAR;
6350 newss->expr = ar->start[n];
6357 newss = gfc_get_ss ();
6358 newss->type = GFC_SS_SECTION;
6361 newss->data.info.dimen = ar->as->rank;
6362 newss->data.info.ref = ref;
6364 /* Make sure array is the same as array(:,:), this way
6365 we don't need to special case all the time. */
6366 ar->dimen = ar->as->rank;
6367 for (n = 0; n < ar->dimen; n++)
6369 newss->data.info.dim[n] = n;
6370 ar->dimen_type[n] = DIMEN_RANGE;
6372 gcc_assert (ar->start[n] == NULL);
6373 gcc_assert (ar->end[n] == NULL);
6374 gcc_assert (ar->stride[n] == NULL);
6380 newss = gfc_get_ss ();
6381 newss->type = GFC_SS_SECTION;
6384 newss->data.info.dimen = 0;
6385 newss->data.info.ref = ref;
6387 /* We add SS chains for all the subscripts in the section. */
6388 for (n = 0; n < ar->dimen; n++)
6392 switch (ar->dimen_type[n])
6395 /* Add SS for elemental (scalar) subscripts. */
6396 gcc_assert (ar->start[n]);
6397 indexss = gfc_get_ss ();
6398 indexss->type = GFC_SS_SCALAR;
6399 indexss->expr = ar->start[n];
6400 indexss->next = gfc_ss_terminator;
6401 indexss->loop_chain = gfc_ss_terminator;
6402 newss->data.info.subscript[n] = indexss;
6406 /* We don't add anything for sections, just remember this
6407 dimension for later. */
6408 newss->data.info.dim[newss->data.info.dimen] = n;
6409 newss->data.info.dimen++;
6413 /* Create a GFC_SS_VECTOR index in which we can store
6414 the vector's descriptor. */
6415 indexss = gfc_get_ss ();
6416 indexss->type = GFC_SS_VECTOR;
6417 indexss->expr = ar->start[n];
6418 indexss->next = gfc_ss_terminator;
6419 indexss->loop_chain = gfc_ss_terminator;
6420 newss->data.info.subscript[n] = indexss;
6421 newss->data.info.dim[newss->data.info.dimen] = n;
6422 newss->data.info.dimen++;
6426 /* We should know what sort of section it is by now. */
6430 /* We should have at least one non-elemental dimension. */
6431 gcc_assert (newss->data.info.dimen > 0);
6436 /* We should know what sort of section it is by now. */
6445 /* Walk an expression operator. If only one operand of a binary expression is
6446 scalar, we must also add the scalar term to the SS chain. */
6449 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6455 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6456 if (expr->value.op.op2 == NULL)
6459 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6461 /* All operands are scalar. Pass back and let the caller deal with it. */
6465 /* All operands require scalarization. */
6466 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6469 /* One of the operands needs scalarization, the other is scalar.
6470 Create a gfc_ss for the scalar expression. */
6471 newss = gfc_get_ss ();
6472 newss->type = GFC_SS_SCALAR;
6475 /* First operand is scalar. We build the chain in reverse order, so
6476 add the scalar SS after the second operand. */
6478 while (head && head->next != ss)
6480 /* Check we haven't somehow broken the chain. */
6484 newss->expr = expr->value.op.op1;
6486 else /* head2 == head */
6488 gcc_assert (head2 == head);
6489 /* Second operand is scalar. */
6490 newss->next = head2;
6492 newss->expr = expr->value.op.op2;
6499 /* Reverse a SS chain. */
6502 gfc_reverse_ss (gfc_ss * ss)
6507 gcc_assert (ss != NULL);
6509 head = gfc_ss_terminator;
6510 while (ss != gfc_ss_terminator)
6513 /* Check we didn't somehow break the chain. */
6514 gcc_assert (next != NULL);
6524 /* Walk the arguments of an elemental function. */
6527 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6535 head = gfc_ss_terminator;
6538 for (; arg; arg = arg->next)
6543 newss = gfc_walk_subexpr (head, arg->expr);
6546 /* Scalar argument. */
6547 newss = gfc_get_ss ();
6549 newss->expr = arg->expr;
6559 while (tail->next != gfc_ss_terminator)
6566 /* If all the arguments are scalar we don't need the argument SS. */
6567 gfc_free_ss_chain (head);
6572 /* Add it onto the existing chain. */
6578 /* Walk a function call. Scalar functions are passed back, and taken out of
6579 scalarization loops. For elemental functions we walk their arguments.
6580 The result of functions returning arrays is stored in a temporary outside
6581 the loop, so that the function is only called once. Hence we do not need
6582 to walk their arguments. */
6585 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6588 gfc_intrinsic_sym *isym;
6590 gfc_component *comp = NULL;
6592 isym = expr->value.function.isym;
6594 /* Handle intrinsic functions separately. */
6596 return gfc_walk_intrinsic_function (ss, expr, isym);
6598 sym = expr->value.function.esym;
6600 sym = expr->symtree->n.sym;
6602 /* A function that returns arrays. */
6603 gfc_is_proc_ptr_comp (expr, &comp);
6604 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6605 || (comp && comp->attr.dimension))
6607 newss = gfc_get_ss ();
6608 newss->type = GFC_SS_FUNCTION;
6611 newss->data.info.dimen = expr->rank;
6615 /* Walk the parameters of an elemental function. For now we always pass
6617 if (sym->attr.elemental)
6618 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6621 /* Scalar functions are OK as these are evaluated outside the scalarization
6622 loop. Pass back and let the caller deal with it. */
6627 /* An array temporary is constructed for array constructors. */
6630 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6635 newss = gfc_get_ss ();
6636 newss->type = GFC_SS_CONSTRUCTOR;
6639 newss->data.info.dimen = expr->rank;
6640 for (n = 0; n < expr->rank; n++)
6641 newss->data.info.dim[n] = n;
6647 /* Walk an expression. Add walked expressions to the head of the SS chain.
6648 A wholly scalar expression will not be added. */
6651 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6655 switch (expr->expr_type)
6658 head = gfc_walk_variable_expr (ss, expr);
6662 head = gfc_walk_op_expr (ss, expr);
6666 head = gfc_walk_function_expr (ss, expr);
6671 case EXPR_STRUCTURE:
6672 /* Pass back and let the caller deal with it. */
6676 head = gfc_walk_array_constructor (ss, expr);
6679 case EXPR_SUBSTRING:
6680 /* Pass back and let the caller deal with it. */
6684 internal_error ("bad expression type during walk (%d)",
6691 /* Entry point for expression walking.
6692 A return value equal to the passed chain means this is
6693 a scalar expression. It is up to the caller to take whatever action is
6694 necessary to translate these. */
6697 gfc_walk_expr (gfc_expr * expr)
6701 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6702 return gfc_reverse_ss (res);