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 || 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 || 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 || ar->as->type != AS_ASSUMED_SIZE)
2586 tmp = gfc_conv_array_ubound (se->expr, n);
2587 if (sym->attr.temporary)
2589 gfc_init_se (&tmpse, se);
2590 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2591 gfc_array_index_type);
2592 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2596 cond = fold_build2 (GT_EXPR, boolean_type_node,
2598 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2599 "above upper bound of %%ld", n+1, sym->name);
2600 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2601 fold_convert (long_integer_type_node,
2603 fold_convert (long_integer_type_node, tmp));
2608 /* Multiply the index by the stride. */
2609 stride = gfc_conv_array_stride (se->expr, n);
2610 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2613 /* And add it to the total. */
2614 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2617 tmp = gfc_conv_array_offset (se->expr);
2618 if (!integer_zerop (tmp))
2619 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2621 /* Access the calculated element. */
2622 tmp = gfc_conv_array_data (se->expr);
2623 tmp = build_fold_indirect_ref (tmp);
2624 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2628 /* Generate the code to be executed immediately before entering a
2629 scalarization loop. */
2632 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2633 stmtblock_t * pblock)
2642 /* This code will be executed before entering the scalarization loop
2643 for this dimension. */
2644 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2646 if ((ss->useflags & flag) == 0)
2649 if (ss->type != GFC_SS_SECTION
2650 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2651 && ss->type != GFC_SS_COMPONENT)
2654 info = &ss->data.info;
2656 if (dim >= info->dimen)
2659 if (dim == info->dimen - 1)
2661 /* For the outermost loop calculate the offset due to any
2662 elemental dimensions. It will have been initialized with the
2663 base offset of the array. */
2666 for (i = 0; i < info->ref->u.ar.dimen; i++)
2668 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2671 gfc_init_se (&se, NULL);
2673 se.expr = info->descriptor;
2674 stride = gfc_conv_array_stride (info->descriptor, i);
2675 index = gfc_conv_array_index_offset (&se, info, i, -1,
2678 gfc_add_block_to_block (pblock, &se.pre);
2680 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2681 info->offset, index);
2682 info->offset = gfc_evaluate_now (info->offset, pblock);
2686 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2689 stride = gfc_conv_array_stride (info->descriptor, 0);
2691 /* Calculate the stride of the innermost loop. Hopefully this will
2692 allow the backend optimizers to do their stuff more effectively.
2694 info->stride0 = gfc_evaluate_now (stride, pblock);
2698 /* Add the offset for the previous loop dimension. */
2703 ar = &info->ref->u.ar;
2704 i = loop->order[dim + 1];
2712 gfc_init_se (&se, NULL);
2714 se.expr = info->descriptor;
2715 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2716 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2718 gfc_add_block_to_block (pblock, &se.pre);
2719 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2720 info->offset, index);
2721 info->offset = gfc_evaluate_now (info->offset, pblock);
2724 /* Remember this offset for the second loop. */
2725 if (dim == loop->temp_dim - 1)
2726 info->saved_offset = info->offset;
2731 /* Start a scalarized expression. Creates a scope and declares loop
2735 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2741 gcc_assert (!loop->array_parameter);
2743 for (dim = loop->dimen - 1; dim >= 0; dim--)
2745 n = loop->order[dim];
2747 gfc_start_block (&loop->code[n]);
2749 /* Create the loop variable. */
2750 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2752 if (dim < loop->temp_dim)
2756 /* Calculate values that will be constant within this loop. */
2757 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2759 gfc_start_block (pbody);
2763 /* Generates the actual loop code for a scalarization loop. */
2766 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2767 stmtblock_t * pbody)
2778 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2779 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2780 && n == loop->dimen - 1)
2782 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2783 init = make_tree_vec (1);
2784 cond = make_tree_vec (1);
2785 incr = make_tree_vec (1);
2787 /* Cycle statement is implemented with a goto. Exit statement must not
2788 be present for this loop. */
2789 exit_label = gfc_build_label_decl (NULL_TREE);
2790 TREE_USED (exit_label) = 1;
2792 /* Label for cycle statements (if needed). */
2793 tmp = build1_v (LABEL_EXPR, exit_label);
2794 gfc_add_expr_to_block (pbody, tmp);
2796 stmt = make_node (OMP_FOR);
2798 TREE_TYPE (stmt) = void_type_node;
2799 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2801 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2802 OMP_CLAUSE_SCHEDULE);
2803 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2804 = OMP_CLAUSE_SCHEDULE_STATIC;
2805 if (ompws_flags & OMPWS_NOWAIT)
2806 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2807 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2809 /* Initialize the loopvar. */
2810 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2812 OMP_FOR_INIT (stmt) = init;
2813 /* The exit condition. */
2814 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2815 loop->loopvar[n], loop->to[n]);
2816 OMP_FOR_COND (stmt) = cond;
2817 /* Increment the loopvar. */
2818 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2819 loop->loopvar[n], gfc_index_one_node);
2820 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2821 void_type_node, loop->loopvar[n], tmp);
2822 OMP_FOR_INCR (stmt) = incr;
2824 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2825 gfc_add_expr_to_block (&loop->code[n], stmt);
2829 loopbody = gfc_finish_block (pbody);
2831 /* Initialize the loopvar. */
2832 if (loop->loopvar[n] != loop->from[n])
2833 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2835 exit_label = gfc_build_label_decl (NULL_TREE);
2837 /* Generate the loop body. */
2838 gfc_init_block (&block);
2840 /* The exit condition. */
2841 cond = fold_build2 (GT_EXPR, boolean_type_node,
2842 loop->loopvar[n], loop->to[n]);
2843 tmp = build1_v (GOTO_EXPR, exit_label);
2844 TREE_USED (exit_label) = 1;
2845 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2846 gfc_add_expr_to_block (&block, tmp);
2848 /* The main body. */
2849 gfc_add_expr_to_block (&block, loopbody);
2851 /* Increment the loopvar. */
2852 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2853 loop->loopvar[n], gfc_index_one_node);
2854 gfc_add_modify (&block, loop->loopvar[n], tmp);
2856 /* Build the loop. */
2857 tmp = gfc_finish_block (&block);
2858 tmp = build1_v (LOOP_EXPR, tmp);
2859 gfc_add_expr_to_block (&loop->code[n], tmp);
2861 /* Add the exit label. */
2862 tmp = build1_v (LABEL_EXPR, exit_label);
2863 gfc_add_expr_to_block (&loop->code[n], tmp);
2869 /* Finishes and generates the loops for a scalarized expression. */
2872 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2877 stmtblock_t *pblock;
2881 /* Generate the loops. */
2882 for (dim = 0; dim < loop->dimen; dim++)
2884 n = loop->order[dim];
2885 gfc_trans_scalarized_loop_end (loop, n, pblock);
2886 loop->loopvar[n] = NULL_TREE;
2887 pblock = &loop->code[n];
2890 tmp = gfc_finish_block (pblock);
2891 gfc_add_expr_to_block (&loop->pre, tmp);
2893 /* Clear all the used flags. */
2894 for (ss = loop->ss; ss; ss = ss->loop_chain)
2899 /* Finish the main body of a scalarized expression, and start the secondary
2903 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2907 stmtblock_t *pblock;
2911 /* We finish as many loops as are used by the temporary. */
2912 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2914 n = loop->order[dim];
2915 gfc_trans_scalarized_loop_end (loop, n, pblock);
2916 loop->loopvar[n] = NULL_TREE;
2917 pblock = &loop->code[n];
2920 /* We don't want to finish the outermost loop entirely. */
2921 n = loop->order[loop->temp_dim - 1];
2922 gfc_trans_scalarized_loop_end (loop, n, pblock);
2924 /* Restore the initial offsets. */
2925 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2927 if ((ss->useflags & 2) == 0)
2930 if (ss->type != GFC_SS_SECTION
2931 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2932 && ss->type != GFC_SS_COMPONENT)
2935 ss->data.info.offset = ss->data.info.saved_offset;
2938 /* Restart all the inner loops we just finished. */
2939 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2941 n = loop->order[dim];
2943 gfc_start_block (&loop->code[n]);
2945 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2947 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2950 /* Start a block for the secondary copying code. */
2951 gfc_start_block (body);
2955 /* Calculate the upper bound of an array section. */
2958 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2967 gcc_assert (ss->type == GFC_SS_SECTION);
2969 info = &ss->data.info;
2972 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2973 /* We'll calculate the upper bound once we have access to the
2974 vector's descriptor. */
2977 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2978 desc = info->descriptor;
2979 end = info->ref->u.ar.end[dim];
2983 /* The upper bound was specified. */
2984 gfc_init_se (&se, NULL);
2985 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2986 gfc_add_block_to_block (pblock, &se.pre);
2991 /* No upper bound was specified, so use the bound of the array. */
2992 bound = gfc_conv_array_ubound (desc, dim);
2999 /* Calculate the lower bound of an array section. */
3002 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3012 gcc_assert (ss->type == GFC_SS_SECTION);
3014 info = &ss->data.info;
3017 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3019 /* We use a zero-based index to access the vector. */
3020 info->start[n] = gfc_index_zero_node;
3021 info->end[n] = gfc_index_zero_node;
3022 info->stride[n] = gfc_index_one_node;
3026 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3027 desc = info->descriptor;
3028 start = info->ref->u.ar.start[dim];
3029 end = info->ref->u.ar.end[dim];
3030 stride = info->ref->u.ar.stride[dim];
3032 /* Calculate the start of the range. For vector subscripts this will
3033 be the range of the vector. */
3036 /* Specified section start. */
3037 gfc_init_se (&se, NULL);
3038 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3039 gfc_add_block_to_block (&loop->pre, &se.pre);
3040 info->start[n] = se.expr;
3044 /* No lower bound specified so use the bound of the array. */
3045 info->start[n] = gfc_conv_array_lbound (desc, dim);
3047 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3049 /* Similarly calculate the end. Although this is not used in the
3050 scalarizer, it is needed when checking bounds and where the end
3051 is an expression with side-effects. */
3054 /* Specified section start. */
3055 gfc_init_se (&se, NULL);
3056 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3057 gfc_add_block_to_block (&loop->pre, &se.pre);
3058 info->end[n] = se.expr;
3062 /* No upper bound specified so use the bound of the array. */
3063 info->end[n] = gfc_conv_array_ubound (desc, dim);
3065 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3067 /* Calculate the stride. */
3069 info->stride[n] = gfc_index_one_node;
3072 gfc_init_se (&se, NULL);
3073 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3074 gfc_add_block_to_block (&loop->pre, &se.pre);
3075 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3080 /* Calculates the range start and stride for a SS chain. Also gets the
3081 descriptor and data pointer. The range of vector subscripts is the size
3082 of the vector. Array bounds are also checked. */
3085 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3093 /* Determine the rank of the loop. */
3095 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3099 case GFC_SS_SECTION:
3100 case GFC_SS_CONSTRUCTOR:
3101 case GFC_SS_FUNCTION:
3102 case GFC_SS_COMPONENT:
3103 loop->dimen = ss->data.info.dimen;
3106 /* As usual, lbound and ubound are exceptions!. */
3107 case GFC_SS_INTRINSIC:
3108 switch (ss->expr->value.function.isym->id)
3110 case GFC_ISYM_LBOUND:
3111 case GFC_ISYM_UBOUND:
3112 loop->dimen = ss->data.info.dimen;
3123 /* We should have determined the rank of the expression by now. If
3124 not, that's bad news. */
3125 gcc_assert (loop->dimen != 0);
3127 /* Loop over all the SS in the chain. */
3128 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3130 if (ss->expr && ss->expr->shape && !ss->shape)
3131 ss->shape = ss->expr->shape;
3135 case GFC_SS_SECTION:
3136 /* Get the descriptor for the array. */
3137 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3139 for (n = 0; n < ss->data.info.dimen; n++)
3140 gfc_conv_section_startstride (loop, ss, n);
3143 case GFC_SS_INTRINSIC:
3144 switch (ss->expr->value.function.isym->id)
3146 /* Fall through to supply start and stride. */
3147 case GFC_ISYM_LBOUND:
3148 case GFC_ISYM_UBOUND:
3154 case GFC_SS_CONSTRUCTOR:
3155 case GFC_SS_FUNCTION:
3156 for (n = 0; n < ss->data.info.dimen; n++)
3158 ss->data.info.start[n] = gfc_index_zero_node;
3159 ss->data.info.end[n] = gfc_index_zero_node;
3160 ss->data.info.stride[n] = gfc_index_one_node;
3169 /* The rest is just runtime bound checking. */
3170 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3173 tree lbound, ubound;
3175 tree size[GFC_MAX_DIMENSIONS];
3176 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3181 gfc_start_block (&block);
3183 for (n = 0; n < loop->dimen; n++)
3184 size[n] = NULL_TREE;
3186 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3190 if (ss->type != GFC_SS_SECTION)
3193 gfc_start_block (&inner);
3195 /* TODO: range checking for mapped dimensions. */
3196 info = &ss->data.info;
3198 /* This code only checks ranges. Elemental and vector
3199 dimensions are checked later. */
3200 for (n = 0; n < loop->dimen; n++)
3205 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3208 if (dim == info->ref->u.ar.dimen - 1
3209 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3210 check_upper = false;
3214 /* Zero stride is not allowed. */
3215 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3216 gfc_index_zero_node);
3217 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3218 "of array '%s'", info->dim[n]+1,
3219 ss->expr->symtree->name);
3220 gfc_trans_runtime_check (true, false, tmp, &inner,
3221 &ss->expr->where, msg);
3224 desc = ss->data.info.descriptor;
3226 /* This is the run-time equivalent of resolve.c's
3227 check_dimension(). The logical is more readable there
3228 than it is here, with all the trees. */
3229 lbound = gfc_conv_array_lbound (desc, dim);
3232 ubound = gfc_conv_array_ubound (desc, dim);
3236 /* non_zerosized is true when the selected range is not
3238 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3239 info->stride[n], gfc_index_zero_node);
3240 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3242 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3245 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3246 info->stride[n], gfc_index_zero_node);
3247 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3249 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3251 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3252 stride_pos, stride_neg);
3254 /* Check the start of the range against the lower and upper
3255 bounds of the array, if the range is not empty.
3256 If upper bound is present, include both bounds in the
3260 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3261 info->start[n], lbound);
3262 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3263 non_zerosized, tmp);
3264 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3265 info->start[n], ubound);
3266 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3267 non_zerosized, tmp2);
3268 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3269 "outside of expected range (%%ld:%%ld)",
3270 info->dim[n]+1, ss->expr->symtree->name);
3271 gfc_trans_runtime_check (true, false, tmp, &inner,
3272 &ss->expr->where, msg,
3273 fold_convert (long_integer_type_node, info->start[n]),
3274 fold_convert (long_integer_type_node, lbound),
3275 fold_convert (long_integer_type_node, ubound));
3276 gfc_trans_runtime_check (true, false, tmp2, &inner,
3277 &ss->expr->where, msg,
3278 fold_convert (long_integer_type_node, info->start[n]),
3279 fold_convert (long_integer_type_node, lbound),
3280 fold_convert (long_integer_type_node, ubound));
3285 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3286 info->start[n], lbound);
3287 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3288 non_zerosized, tmp);
3289 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3290 "below lower bound of %%ld",
3291 info->dim[n]+1, ss->expr->symtree->name);
3292 gfc_trans_runtime_check (true, false, tmp, &inner,
3293 &ss->expr->where, msg,
3294 fold_convert (long_integer_type_node, info->start[n]),
3295 fold_convert (long_integer_type_node, lbound));
3299 /* Compute the last element of the range, which is not
3300 necessarily "end" (think 0:5:3, which doesn't contain 5)
3301 and check it against both lower and upper bounds. */
3303 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3305 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3307 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3309 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3310 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3311 non_zerosized, tmp2);
3314 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3315 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3316 non_zerosized, tmp3);
3317 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3318 "outside of expected range (%%ld:%%ld)",
3319 info->dim[n]+1, ss->expr->symtree->name);
3320 gfc_trans_runtime_check (true, false, tmp2, &inner,
3321 &ss->expr->where, msg,
3322 fold_convert (long_integer_type_node, tmp),
3323 fold_convert (long_integer_type_node, ubound),
3324 fold_convert (long_integer_type_node, lbound));
3325 gfc_trans_runtime_check (true, false, tmp3, &inner,
3326 &ss->expr->where, msg,
3327 fold_convert (long_integer_type_node, tmp),
3328 fold_convert (long_integer_type_node, ubound),
3329 fold_convert (long_integer_type_node, lbound));
3334 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3335 "below lower bound of %%ld",
3336 info->dim[n]+1, ss->expr->symtree->name);
3337 gfc_trans_runtime_check (true, false, tmp2, &inner,
3338 &ss->expr->where, msg,
3339 fold_convert (long_integer_type_node, tmp),
3340 fold_convert (long_integer_type_node, lbound));
3344 /* Check the section sizes match. */
3345 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3347 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3349 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3350 gfc_index_one_node, tmp);
3351 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3352 build_int_cst (gfc_array_index_type, 0));
3353 /* We remember the size of the first section, and check all the
3354 others against this. */
3357 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3358 asprintf (&msg, "%s, size mismatch for dimension %d "
3359 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3360 info->dim[n]+1, ss->expr->symtree->name);
3361 gfc_trans_runtime_check (true, false, tmp3, &inner,
3362 &ss->expr->where, msg,
3363 fold_convert (long_integer_type_node, tmp),
3364 fold_convert (long_integer_type_node, size[n]));
3368 size[n] = gfc_evaluate_now (tmp, &inner);
3371 tmp = gfc_finish_block (&inner);
3373 /* For optional arguments, only check bounds if the argument is
3375 if (ss->expr->symtree->n.sym->attr.optional
3376 || ss->expr->symtree->n.sym->attr.not_always_present)
3377 tmp = build3_v (COND_EXPR,
3378 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3379 tmp, build_empty_stmt (input_location));
3381 gfc_add_expr_to_block (&block, tmp);
3385 tmp = gfc_finish_block (&block);
3386 gfc_add_expr_to_block (&loop->pre, tmp);
3391 /* Return true if the two SS could be aliased, i.e. both point to the same data
3393 /* TODO: resolve aliases based on frontend expressions. */
3396 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3403 lsym = lss->expr->symtree->n.sym;
3404 rsym = rss->expr->symtree->n.sym;
3405 if (gfc_symbols_could_alias (lsym, rsym))
3408 if (rsym->ts.type != BT_DERIVED
3409 && lsym->ts.type != BT_DERIVED)
3412 /* For derived types we must check all the component types. We can ignore
3413 array references as these will have the same base type as the previous
3415 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3417 if (lref->type != REF_COMPONENT)
3420 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3423 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3426 if (rref->type != REF_COMPONENT)
3429 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3434 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3436 if (rref->type != REF_COMPONENT)
3439 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3447 /* Resolve array data dependencies. Creates a temporary if required. */
3448 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3452 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3460 loop->temp_ss = NULL;
3462 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3464 if (ss->type != GFC_SS_SECTION)
3467 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3469 if (gfc_could_be_alias (dest, ss)
3470 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3478 lref = dest->expr->ref;
3479 rref = ss->expr->ref;
3481 nDepend = gfc_dep_resolver (lref, rref);
3485 /* TODO : loop shifting. */
3488 /* Mark the dimensions for LOOP SHIFTING */
3489 for (n = 0; n < loop->dimen; n++)
3491 int dim = dest->data.info.dim[n];
3493 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3495 else if (! gfc_is_same_range (&lref->u.ar,
3496 &rref->u.ar, dim, 0))
3500 /* Put all the dimensions with dependencies in the
3503 for (n = 0; n < loop->dimen; n++)
3505 gcc_assert (loop->order[n] == n);
3507 loop->order[dim++] = n;
3509 for (n = 0; n < loop->dimen; n++)
3512 loop->order[dim++] = n;
3515 gcc_assert (dim == loop->dimen);
3524 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3525 if (GFC_ARRAY_TYPE_P (base_type)
3526 || GFC_DESCRIPTOR_TYPE_P (base_type))
3527 base_type = gfc_get_element_type (base_type);
3528 loop->temp_ss = gfc_get_ss ();
3529 loop->temp_ss->type = GFC_SS_TEMP;
3530 loop->temp_ss->data.temp.type = base_type;
3531 loop->temp_ss->string_length = dest->string_length;
3532 loop->temp_ss->data.temp.dimen = loop->dimen;
3533 loop->temp_ss->next = gfc_ss_terminator;
3534 gfc_add_ss_to_loop (loop, loop->temp_ss);
3537 loop->temp_ss = NULL;
3541 /* Initialize the scalarization loop. Creates the loop variables. Determines
3542 the range of the loop variables. Creates a temporary if required.
3543 Calculates how to transform from loop variables to array indices for each
3544 expression. Also generates code for scalar expressions which have been
3545 moved outside the loop. */
3548 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3552 gfc_ss_info *specinfo;
3555 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3556 bool dynamic[GFC_MAX_DIMENSIONS];
3562 for (n = 0; n < loop->dimen; n++)
3566 /* We use one SS term, and use that to determine the bounds of the
3567 loop for this dimension. We try to pick the simplest term. */
3568 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3572 /* The frontend has worked out the size for us. */
3573 if (!loopspec[n] || !loopspec[n]->shape
3574 || !integer_zerop (loopspec[n]->data.info.start[n]))
3575 /* Prefer zero-based descriptors if possible. */
3580 if (ss->type == GFC_SS_CONSTRUCTOR)
3582 /* An unknown size constructor will always be rank one.
3583 Higher rank constructors will either have known shape,
3584 or still be wrapped in a call to reshape. */
3585 gcc_assert (loop->dimen == 1);
3587 /* Always prefer to use the constructor bounds if the size
3588 can be determined at compile time. Prefer not to otherwise,
3589 since the general case involves realloc, and it's better to
3590 avoid that overhead if possible. */
3591 c = ss->expr->value.constructor;
3592 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3593 if (!dynamic[n] || !loopspec[n])
3598 /* TODO: Pick the best bound if we have a choice between a
3599 function and something else. */
3600 if (ss->type == GFC_SS_FUNCTION)
3606 if (ss->type != GFC_SS_SECTION)
3610 specinfo = &loopspec[n]->data.info;
3613 info = &ss->data.info;
3617 /* Criteria for choosing a loop specifier (most important first):
3618 doesn't need realloc
3624 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3626 else if (integer_onep (info->stride[n])
3627 && !integer_onep (specinfo->stride[n]))
3629 else if (INTEGER_CST_P (info->stride[n])
3630 && !INTEGER_CST_P (specinfo->stride[n]))
3632 else if (INTEGER_CST_P (info->start[n])
3633 && !INTEGER_CST_P (specinfo->start[n]))
3635 /* We don't work out the upper bound.
3636 else if (INTEGER_CST_P (info->finish[n])
3637 && ! INTEGER_CST_P (specinfo->finish[n]))
3638 loopspec[n] = ss; */
3641 /* We should have found the scalarization loop specifier. If not,
3643 gcc_assert (loopspec[n]);
3645 info = &loopspec[n]->data.info;
3647 /* Set the extents of this range. */
3648 cshape = loopspec[n]->shape;
3649 if (cshape && INTEGER_CST_P (info->start[n])
3650 && INTEGER_CST_P (info->stride[n]))
3652 loop->from[n] = info->start[n];
3653 mpz_set (i, cshape[n]);
3654 mpz_sub_ui (i, i, 1);
3655 /* To = from + (size - 1) * stride. */
3656 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3657 if (!integer_onep (info->stride[n]))
3658 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3659 tmp, info->stride[n]);
3660 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3661 loop->from[n], tmp);
3665 loop->from[n] = info->start[n];
3666 switch (loopspec[n]->type)
3668 case GFC_SS_CONSTRUCTOR:
3669 /* The upper bound is calculated when we expand the
3671 gcc_assert (loop->to[n] == NULL_TREE);
3674 case GFC_SS_SECTION:
3675 /* Use the end expression if it exists and is not constant,
3676 so that it is only evaluated once. */
3677 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3678 loop->to[n] = info->end[n];
3680 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3684 case GFC_SS_FUNCTION:
3685 /* The loop bound will be set when we generate the call. */
3686 gcc_assert (loop->to[n] == NULL_TREE);
3694 /* Transform everything so we have a simple incrementing variable. */
3695 if (integer_onep (info->stride[n]))
3696 info->delta[n] = gfc_index_zero_node;
3699 /* Set the delta for this section. */
3700 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3701 /* Number of iterations is (end - start + step) / step.
3702 with start = 0, this simplifies to
3704 for (i = 0; i<=last; i++){...}; */
3705 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3706 loop->to[n], loop->from[n]);
3707 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3708 tmp, info->stride[n]);
3709 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3710 build_int_cst (gfc_array_index_type, -1));
3711 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3712 /* Make the loop variable start at 0. */
3713 loop->from[n] = gfc_index_zero_node;
3717 /* Add all the scalar code that can be taken out of the loops.
3718 This may include calculating the loop bounds, so do it before
3719 allocating the temporary. */
3720 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3722 /* If we want a temporary then create it. */
3723 if (loop->temp_ss != NULL)
3725 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3727 /* Make absolutely sure that this is a complete type. */
3728 if (loop->temp_ss->string_length)
3729 loop->temp_ss->data.temp.type
3730 = gfc_get_character_type_len_for_eltype
3731 (TREE_TYPE (loop->temp_ss->data.temp.type),
3732 loop->temp_ss->string_length);
3734 tmp = loop->temp_ss->data.temp.type;
3735 n = loop->temp_ss->data.temp.dimen;
3736 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3737 loop->temp_ss->type = GFC_SS_SECTION;
3738 loop->temp_ss->data.info.dimen = n;
3739 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3740 &loop->temp_ss->data.info, tmp, NULL_TREE,
3741 false, true, false, where);
3744 for (n = 0; n < loop->temp_dim; n++)
3745 loopspec[loop->order[n]] = NULL;
3749 /* For array parameters we don't have loop variables, so don't calculate the
3751 if (loop->array_parameter)
3754 /* Calculate the translation from loop variables to array indices. */
3755 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3757 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3758 && ss->type != GFC_SS_CONSTRUCTOR)
3762 info = &ss->data.info;
3764 for (n = 0; n < info->dimen; n++)
3766 /* If we are specifying the range the delta is already set. */
3767 if (loopspec[n] != ss)
3769 /* Calculate the offset relative to the loop variable.
3770 First multiply by the stride. */
3771 tmp = loop->from[n];
3772 if (!integer_onep (info->stride[n]))
3773 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3774 tmp, info->stride[n]);
3776 /* Then subtract this from our starting value. */
3777 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3778 info->start[n], tmp);
3780 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3787 /* Fills in an array descriptor, and returns the size of the array. The size
3788 will be a simple_val, ie a variable or a constant. Also calculates the
3789 offset of the base. Returns the size of the array.
3793 for (n = 0; n < rank; n++)
3795 a.lbound[n] = specified_lower_bound;
3796 offset = offset + a.lbond[n] * stride;
3798 a.ubound[n] = specified_upper_bound;
3799 a.stride[n] = stride;
3800 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3801 stride = stride * size;
3808 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3809 gfc_expr ** lower, gfc_expr ** upper,
3810 stmtblock_t * pblock)
3822 stmtblock_t thenblock;
3823 stmtblock_t elseblock;
3828 type = TREE_TYPE (descriptor);
3830 stride = gfc_index_one_node;
3831 offset = gfc_index_zero_node;
3833 /* Set the dtype. */
3834 tmp = gfc_conv_descriptor_dtype (descriptor);
3835 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3837 or_expr = NULL_TREE;
3839 for (n = 0; n < rank; n++)
3841 /* We have 3 possibilities for determining the size of the array:
3842 lower == NULL => lbound = 1, ubound = upper[n]
3843 upper[n] = NULL => lbound = 1, ubound = lower[n]
3844 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3847 /* Set lower bound. */
3848 gfc_init_se (&se, NULL);
3850 se.expr = gfc_index_one_node;
3853 gcc_assert (lower[n]);
3856 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3857 gfc_add_block_to_block (pblock, &se.pre);
3861 se.expr = gfc_index_one_node;
3865 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3868 /* Work out the offset for this component. */
3869 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3870 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3872 /* Start the calculation for the size of this dimension. */
3873 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3874 gfc_index_one_node, se.expr);
3876 /* Set upper bound. */
3877 gfc_init_se (&se, NULL);
3878 gcc_assert (ubound);
3879 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3880 gfc_add_block_to_block (pblock, &se.pre);
3882 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3884 /* Store the stride. */
3885 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3887 /* Calculate the size of this dimension. */
3888 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3890 /* Check whether the size for this dimension is negative. */
3891 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3892 gfc_index_zero_node);
3896 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3898 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3899 gfc_index_zero_node, size);
3901 /* Multiply the stride by the number of elements in this dimension. */
3902 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3903 stride = gfc_evaluate_now (stride, pblock);
3906 /* The stride is the number of elements in the array, so multiply by the
3907 size of an element to get the total size. */
3908 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3909 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3910 fold_convert (gfc_array_index_type, tmp));
3912 if (poffset != NULL)
3914 offset = gfc_evaluate_now (offset, pblock);
3918 if (integer_zerop (or_expr))
3920 if (integer_onep (or_expr))
3921 return gfc_index_zero_node;
3923 var = gfc_create_var (TREE_TYPE (size), "size");
3924 gfc_start_block (&thenblock);
3925 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3926 thencase = gfc_finish_block (&thenblock);
3928 gfc_start_block (&elseblock);
3929 gfc_add_modify (&elseblock, var, size);
3930 elsecase = gfc_finish_block (&elseblock);
3932 tmp = gfc_evaluate_now (or_expr, pblock);
3933 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3934 gfc_add_expr_to_block (pblock, tmp);
3940 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3941 the work for an ALLOCATE statement. */
3945 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3953 gfc_ref *ref, *prev_ref = NULL;
3954 bool allocatable_array;
3958 /* Find the last reference in the chain. */
3959 while (ref && ref->next != NULL)
3961 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3966 if (ref == NULL || ref->type != REF_ARRAY)
3970 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3972 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3974 /* Figure out the size of the array. */
3975 switch (ref->u.ar.type)
3979 upper = ref->u.ar.start;
3983 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3985 lower = ref->u.ar.as->lower;
3986 upper = ref->u.ar.as->upper;
3990 lower = ref->u.ar.start;
3991 upper = ref->u.ar.end;
3999 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
4000 lower, upper, &se->pre);
4002 /* Allocate memory to store the data. */
4003 pointer = gfc_conv_descriptor_data_get (se->expr);
4004 STRIP_NOPS (pointer);
4006 /* The allocate_array variants take the old pointer as first argument. */
4007 if (allocatable_array)
4008 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4010 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4011 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4012 gfc_add_expr_to_block (&se->pre, tmp);
4014 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4016 if (expr->ts.type == BT_DERIVED
4017 && expr->ts.u.derived->attr.alloc_comp)
4019 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4020 ref->u.ar.as->rank);
4021 gfc_add_expr_to_block (&se->pre, tmp);
4028 /* Deallocate an array variable. Also used when an allocated variable goes
4033 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4039 gfc_start_block (&block);
4040 /* Get a pointer to the data. */
4041 var = gfc_conv_descriptor_data_get (descriptor);
4044 /* Parameter is the address of the data component. */
4045 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4046 gfc_add_expr_to_block (&block, tmp);
4048 /* Zero the data pointer. */
4049 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4050 var, build_int_cst (TREE_TYPE (var), 0));
4051 gfc_add_expr_to_block (&block, tmp);
4053 return gfc_finish_block (&block);
4057 /* Create an array constructor from an initialization expression.
4058 We assume the frontend already did any expansions and conversions. */
4061 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4068 unsigned HOST_WIDE_INT lo;
4070 VEC(constructor_elt,gc) *v = NULL;
4072 switch (expr->expr_type)
4075 case EXPR_STRUCTURE:
4076 /* A single scalar or derived type value. Create an array with all
4077 elements equal to that value. */
4078 gfc_init_se (&se, NULL);
4080 if (expr->expr_type == EXPR_CONSTANT)
4081 gfc_conv_constant (&se, expr);
4083 gfc_conv_structure (&se, expr, 1);
4085 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4086 gcc_assert (tmp && INTEGER_CST_P (tmp));
4087 hi = TREE_INT_CST_HIGH (tmp);
4088 lo = TREE_INT_CST_LOW (tmp);
4092 /* This will probably eat buckets of memory for large arrays. */
4093 while (hi != 0 || lo != 0)
4095 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4103 /* Create a vector of all the elements. */
4104 for (c = expr->value.constructor; c; c = c->next)
4108 /* Problems occur when we get something like
4109 integer :: a(lots) = (/(i, i=1, lots)/) */
4110 gfc_fatal_error ("The number of elements in the array constructor "
4111 "at %L requires an increase of the allowed %d "
4112 "upper limit. See -fmax-array-constructor "
4113 "option", &expr->where,
4114 gfc_option.flag_max_array_constructor);
4117 if (mpz_cmp_si (c->n.offset, 0) != 0)
4118 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4122 if (mpz_cmp_si (c->repeat, 0) != 0)
4126 mpz_set (maxval, c->repeat);
4127 mpz_add (maxval, c->n.offset, maxval);
4128 mpz_sub_ui (maxval, maxval, 1);
4129 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4130 if (mpz_cmp_si (c->n.offset, 0) != 0)
4132 mpz_add_ui (maxval, c->n.offset, 1);
4133 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4136 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
4138 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
4144 gfc_init_se (&se, NULL);
4145 switch (c->expr->expr_type)
4148 gfc_conv_constant (&se, c->expr);
4149 if (range == NULL_TREE)
4150 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4153 if (index != NULL_TREE)
4154 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4155 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4159 case EXPR_STRUCTURE:
4160 gfc_conv_structure (&se, c->expr, 1);
4161 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4166 /* Catch those occasional beasts that do not simplify
4167 for one reason or another, assuming that if they are
4168 standard defying the frontend will catch them. */
4169 gfc_conv_expr (&se, c->expr);
4170 if (range == NULL_TREE)
4171 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4174 if (index != NULL_TREE)
4175 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4176 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4184 return gfc_build_null_descriptor (type);
4190 /* Create a constructor from the list of elements. */
4191 tmp = build_constructor (type, v);
4192 TREE_CONSTANT (tmp) = 1;
4197 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4198 returns the size (in elements) of the array. */
4201 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4202 stmtblock_t * pblock)
4217 size = gfc_index_one_node;
4218 offset = gfc_index_zero_node;
4219 for (dim = 0; dim < as->rank; dim++)
4221 /* Evaluate non-constant array bound expressions. */
4222 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4223 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4225 gfc_init_se (&se, NULL);
4226 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4227 gfc_add_block_to_block (pblock, &se.pre);
4228 gfc_add_modify (pblock, lbound, se.expr);
4230 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4231 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4233 gfc_init_se (&se, NULL);
4234 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4235 gfc_add_block_to_block (pblock, &se.pre);
4236 gfc_add_modify (pblock, ubound, se.expr);
4238 /* The offset of this dimension. offset = offset - lbound * stride. */
4239 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4240 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4242 /* The size of this dimension, and the stride of the next. */
4243 if (dim + 1 < as->rank)
4244 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4246 stride = GFC_TYPE_ARRAY_SIZE (type);
4248 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4250 /* Calculate stride = size * (ubound + 1 - lbound). */
4251 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4252 gfc_index_one_node, lbound);
4253 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4254 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4256 gfc_add_modify (pblock, stride, tmp);
4258 stride = gfc_evaluate_now (tmp, pblock);
4260 /* Make sure that negative size arrays are translated
4261 to being zero size. */
4262 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4263 stride, gfc_index_zero_node);
4264 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4265 stride, gfc_index_zero_node);
4266 gfc_add_modify (pblock, stride, tmp);
4272 gfc_trans_vla_type_sizes (sym, pblock);
4279 /* Generate code to initialize/allocate an array variable. */
4282 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4291 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4293 /* Do nothing for USEd variables. */
4294 if (sym->attr.use_assoc)
4297 type = TREE_TYPE (decl);
4298 gcc_assert (GFC_ARRAY_TYPE_P (type));
4299 onstack = TREE_CODE (type) != POINTER_TYPE;
4301 gfc_start_block (&block);
4303 /* Evaluate character string length. */
4304 if (sym->ts.type == BT_CHARACTER
4305 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4307 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4309 gfc_trans_vla_type_sizes (sym, &block);
4311 /* Emit a DECL_EXPR for this variable, which will cause the
4312 gimplifier to allocate storage, and all that good stuff. */
4313 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4314 gfc_add_expr_to_block (&block, tmp);
4319 gfc_add_expr_to_block (&block, fnbody);
4320 return gfc_finish_block (&block);
4323 type = TREE_TYPE (type);
4325 gcc_assert (!sym->attr.use_assoc);
4326 gcc_assert (!TREE_STATIC (decl));
4327 gcc_assert (!sym->module);
4329 if (sym->ts.type == BT_CHARACTER
4330 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4331 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4333 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4335 /* Don't actually allocate space for Cray Pointees. */
4336 if (sym->attr.cray_pointee)
4338 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4339 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4340 gfc_add_expr_to_block (&block, fnbody);
4341 return gfc_finish_block (&block);
4344 /* The size is the number of elements in the array, so multiply by the
4345 size of an element to get the total size. */
4346 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4347 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4348 fold_convert (gfc_array_index_type, tmp));
4350 /* Allocate memory to hold the data. */
4351 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4352 gfc_add_modify (&block, decl, tmp);
4354 /* Set offset of the array. */
4355 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4356 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4359 /* Automatic arrays should not have initializers. */
4360 gcc_assert (!sym->value);
4362 gfc_add_expr_to_block (&block, fnbody);
4364 /* Free the temporary. */
4365 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4366 gfc_add_expr_to_block (&block, tmp);
4368 return gfc_finish_block (&block);
4372 /* Generate entry and exit code for g77 calling convention arrays. */
4375 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4385 gfc_get_backend_locus (&loc);
4386 gfc_set_backend_locus (&sym->declared_at);
4388 /* Descriptor type. */
4389 parm = sym->backend_decl;
4390 type = TREE_TYPE (parm);
4391 gcc_assert (GFC_ARRAY_TYPE_P (type));
4393 gfc_start_block (&block);
4395 if (sym->ts.type == BT_CHARACTER
4396 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4397 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4399 /* Evaluate the bounds of the array. */
4400 gfc_trans_array_bounds (type, sym, &offset, &block);
4402 /* Set the offset. */
4403 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4404 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4406 /* Set the pointer itself if we aren't using the parameter directly. */
4407 if (TREE_CODE (parm) != PARM_DECL)
4409 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4410 gfc_add_modify (&block, parm, tmp);
4412 stmt = gfc_finish_block (&block);
4414 gfc_set_backend_locus (&loc);
4416 gfc_start_block (&block);
4418 /* Add the initialization code to the start of the function. */
4420 if (sym->attr.optional || sym->attr.not_always_present)
4422 tmp = gfc_conv_expr_present (sym);
4423 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4426 gfc_add_expr_to_block (&block, stmt);
4427 gfc_add_expr_to_block (&block, body);
4429 return gfc_finish_block (&block);
4433 /* Modify the descriptor of an array parameter so that it has the
4434 correct lower bound. Also move the upper bound accordingly.
4435 If the array is not packed, it will be copied into a temporary.
4436 For each dimension we set the new lower and upper bounds. Then we copy the
4437 stride and calculate the offset for this dimension. We also work out
4438 what the stride of a packed array would be, and see it the two match.
4439 If the array need repacking, we set the stride to the values we just
4440 calculated, recalculate the offset and copy the array data.
4441 Code is also added to copy the data back at the end of the function.
4445 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4452 stmtblock_t cleanup;
4460 tree stride, stride2;
4470 /* Do nothing for pointer and allocatable arrays. */
4471 if (sym->attr.pointer || sym->attr.allocatable)
4474 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4475 return gfc_trans_g77_array (sym, body);
4477 gfc_get_backend_locus (&loc);
4478 gfc_set_backend_locus (&sym->declared_at);
4480 /* Descriptor type. */
4481 type = TREE_TYPE (tmpdesc);
4482 gcc_assert (GFC_ARRAY_TYPE_P (type));
4483 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4484 dumdesc = build_fold_indirect_ref_loc (input_location,
4486 gfc_start_block (&block);
4488 if (sym->ts.type == BT_CHARACTER
4489 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4490 gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
4492 checkparm = (sym->as->type == AS_EXPLICIT
4493 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4495 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4496 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4498 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4500 /* For non-constant shape arrays we only check if the first dimension
4501 is contiguous. Repacking higher dimensions wouldn't gain us
4502 anything as we still don't know the array stride. */
4503 partial = gfc_create_var (boolean_type_node, "partial");
4504 TREE_USED (partial) = 1;
4505 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4506 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4507 gfc_add_modify (&block, partial, tmp);
4511 partial = NULL_TREE;
4514 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4515 here, however I think it does the right thing. */
4518 /* Set the first stride. */
4519 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4520 stride = gfc_evaluate_now (stride, &block);
4522 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4523 stride, gfc_index_zero_node);
4524 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4525 gfc_index_one_node, stride);
4526 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4527 gfc_add_modify (&block, stride, tmp);
4529 /* Allow the user to disable array repacking. */
4530 stmt_unpacked = NULL_TREE;
4534 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4535 /* A library call to repack the array if necessary. */
4536 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4537 stmt_unpacked = build_call_expr_loc (input_location,
4538 gfor_fndecl_in_pack, 1, tmp);
4540 stride = gfc_index_one_node;
4542 if (gfc_option.warn_array_temp)
4543 gfc_warning ("Creating array temporary at %L", &loc);
4546 /* This is for the case where the array data is used directly without
4547 calling the repack function. */
4548 if (no_repack || partial != NULL_TREE)
4549 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4551 stmt_packed = NULL_TREE;
4553 /* Assign the data pointer. */
4554 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4556 /* Don't repack unknown shape arrays when the first stride is 1. */
4557 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4558 partial, stmt_packed, stmt_unpacked);
4561 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4562 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4564 offset = gfc_index_zero_node;
4565 size = gfc_index_one_node;
4567 /* Evaluate the bounds of the array. */
4568 for (n = 0; n < sym->as->rank; n++)
4570 if (checkparm || !sym->as->upper[n])
4572 /* Get the bounds of the actual parameter. */
4573 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4574 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4578 dubound = NULL_TREE;
4579 dlbound = NULL_TREE;
4582 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4583 if (!INTEGER_CST_P (lbound))
4585 gfc_init_se (&se, NULL);
4586 gfc_conv_expr_type (&se, sym->as->lower[n],
4587 gfc_array_index_type);
4588 gfc_add_block_to_block (&block, &se.pre);
4589 gfc_add_modify (&block, lbound, se.expr);
4592 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4593 /* Set the desired upper bound. */
4594 if (sym->as->upper[n])
4596 /* We know what we want the upper bound to be. */
4597 if (!INTEGER_CST_P (ubound))
4599 gfc_init_se (&se, NULL);
4600 gfc_conv_expr_type (&se, sym->as->upper[n],
4601 gfc_array_index_type);
4602 gfc_add_block_to_block (&block, &se.pre);
4603 gfc_add_modify (&block, ubound, se.expr);
4606 /* Check the sizes match. */
4609 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4612 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4614 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4616 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4617 asprintf (&msg, "%s for dimension %d of array '%s'",
4618 gfc_msg_bounds, n+1, sym->name);
4619 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4625 /* For assumed shape arrays move the upper bound by the same amount
4626 as the lower bound. */
4627 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4629 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4630 gfc_add_modify (&block, ubound, tmp);
4632 /* The offset of this dimension. offset = offset - lbound * stride. */
4633 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4634 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4636 /* The size of this dimension, and the stride of the next. */
4637 if (n + 1 < sym->as->rank)
4639 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4641 if (no_repack || partial != NULL_TREE)
4644 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4647 /* Figure out the stride if not a known constant. */
4648 if (!INTEGER_CST_P (stride))
4651 stmt_packed = NULL_TREE;
4654 /* Calculate stride = size * (ubound + 1 - lbound). */
4655 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4656 gfc_index_one_node, lbound);
4657 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4659 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4664 /* Assign the stride. */
4665 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4666 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4667 stmt_unpacked, stmt_packed);
4669 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4670 gfc_add_modify (&block, stride, tmp);
4675 stride = GFC_TYPE_ARRAY_SIZE (type);
4677 if (stride && !INTEGER_CST_P (stride))
4679 /* Calculate size = stride * (ubound + 1 - lbound). */
4680 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4681 gfc_index_one_node, lbound);
4682 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4684 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4685 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4686 gfc_add_modify (&block, stride, tmp);
4691 /* Set the offset. */
4692 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4693 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4695 gfc_trans_vla_type_sizes (sym, &block);
4697 stmt = gfc_finish_block (&block);
4699 gfc_start_block (&block);
4701 /* Only do the entry/initialization code if the arg is present. */
4702 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4703 optional_arg = (sym->attr.optional
4704 || (sym->ns->proc_name->attr.entry_master
4705 && sym->attr.dummy));
4708 tmp = gfc_conv_expr_present (sym);
4709 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4711 gfc_add_expr_to_block (&block, stmt);
4713 /* Add the main function body. */
4714 gfc_add_expr_to_block (&block, body);
4719 gfc_start_block (&cleanup);
4721 if (sym->attr.intent != INTENT_IN)
4723 /* Copy the data back. */
4724 tmp = build_call_expr_loc (input_location,
4725 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4726 gfc_add_expr_to_block (&cleanup, tmp);
4729 /* Free the temporary. */
4730 tmp = gfc_call_free (tmpdesc);
4731 gfc_add_expr_to_block (&cleanup, tmp);
4733 stmt = gfc_finish_block (&cleanup);
4735 /* Only do the cleanup if the array was repacked. */
4736 tmp = build_fold_indirect_ref_loc (input_location,
4738 tmp = gfc_conv_descriptor_data_get (tmp);
4739 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4740 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4744 tmp = gfc_conv_expr_present (sym);
4745 stmt = build3_v (COND_EXPR, tmp, stmt,
4746 build_empty_stmt (input_location));
4748 gfc_add_expr_to_block (&block, stmt);
4750 /* We don't need to free any memory allocated by internal_pack as it will
4751 be freed at the end of the function by pop_context. */
4752 return gfc_finish_block (&block);
4756 /* Calculate the overall offset, including subreferences. */
4758 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4759 bool subref, gfc_expr *expr)
4769 /* If offset is NULL and this is not a subreferenced array, there is
4771 if (offset == NULL_TREE)
4774 offset = gfc_index_zero_node;
4779 tmp = gfc_conv_array_data (desc);
4780 tmp = build_fold_indirect_ref_loc (input_location,
4782 tmp = gfc_build_array_ref (tmp, offset, NULL);
4784 /* Offset the data pointer for pointer assignments from arrays with
4785 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4788 /* Go past the array reference. */
4789 for (ref = expr->ref; ref; ref = ref->next)
4790 if (ref->type == REF_ARRAY &&
4791 ref->u.ar.type != AR_ELEMENT)
4797 /* Calculate the offset for each subsequent subreference. */
4798 for (; ref; ref = ref->next)
4803 field = ref->u.c.component->backend_decl;
4804 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4805 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4806 tmp, field, NULL_TREE);
4810 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4811 gfc_init_se (&start, NULL);
4812 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4813 gfc_add_block_to_block (block, &start.pre);
4814 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4818 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4819 && ref->u.ar.type == AR_ELEMENT);
4821 /* TODO - Add bounds checking. */
4822 stride = gfc_index_one_node;
4823 index = gfc_index_zero_node;
4824 for (n = 0; n < ref->u.ar.dimen; n++)
4829 /* Update the index. */
4830 gfc_init_se (&start, NULL);
4831 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4832 itmp = gfc_evaluate_now (start.expr, block);
4833 gfc_init_se (&start, NULL);
4834 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4835 jtmp = gfc_evaluate_now (start.expr, block);
4836 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4837 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4838 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4839 index = gfc_evaluate_now (index, block);
4841 /* Update the stride. */
4842 gfc_init_se (&start, NULL);
4843 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4844 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4845 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4846 gfc_index_one_node, itmp);
4847 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4848 stride = gfc_evaluate_now (stride, block);
4851 /* Apply the index to obtain the array element. */
4852 tmp = gfc_build_array_ref (tmp, index, NULL);
4862 /* Set the target data pointer. */
4863 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4864 gfc_conv_descriptor_data_set (block, parm, offset);
4868 /* gfc_conv_expr_descriptor needs the string length an expression
4869 so that the size of the temporary can be obtained. This is done
4870 by adding up the string lengths of all the elements in the
4871 expression. Function with non-constant expressions have their
4872 string lengths mapped onto the actual arguments using the
4873 interface mapping machinery in trans-expr.c. */
4875 get_array_charlen (gfc_expr *expr, gfc_se *se)
4877 gfc_interface_mapping mapping;
4878 gfc_formal_arglist *formal;
4879 gfc_actual_arglist *arg;
4882 if (expr->ts.u.cl->length
4883 && gfc_is_constant_expr (expr->ts.u.cl->length))
4885 if (!expr->ts.u.cl->backend_decl)
4886 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4890 switch (expr->expr_type)
4893 get_array_charlen (expr->value.op.op1, se);
4895 /* For parentheses the expression ts.u.cl is identical. */
4896 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4899 expr->ts.u.cl->backend_decl =
4900 gfc_create_var (gfc_charlen_type_node, "sln");
4902 if (expr->value.op.op2)
4904 get_array_charlen (expr->value.op.op2, se);
4906 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4908 /* Add the string lengths and assign them to the expression
4909 string length backend declaration. */
4910 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4911 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4912 expr->value.op.op1->ts.u.cl->backend_decl,
4913 expr->value.op.op2->ts.u.cl->backend_decl));
4916 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4917 expr->value.op.op1->ts.u.cl->backend_decl);
4921 if (expr->value.function.esym == NULL
4922 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4924 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4928 /* Map expressions involving the dummy arguments onto the actual
4929 argument expressions. */
4930 gfc_init_interface_mapping (&mapping);
4931 formal = expr->symtree->n.sym->formal;
4932 arg = expr->value.function.actual;
4934 /* Set se = NULL in the calls to the interface mapping, to suppress any
4936 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4941 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4944 gfc_init_se (&tse, NULL);
4946 /* Build the expression for the character length and convert it. */
4947 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
4949 gfc_add_block_to_block (&se->pre, &tse.pre);
4950 gfc_add_block_to_block (&se->post, &tse.post);
4951 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4952 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4953 build_int_cst (gfc_charlen_type_node, 0));
4954 expr->ts.u.cl->backend_decl = tse.expr;
4955 gfc_free_interface_mapping (&mapping);
4959 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4966 /* Convert an array for passing as an actual argument. Expressions and
4967 vector subscripts are evaluated and stored in a temporary, which is then
4968 passed. For whole arrays the descriptor is passed. For array sections
4969 a modified copy of the descriptor is passed, but using the original data.
4971 This function is also used for array pointer assignments, and there
4974 - se->want_pointer && !se->direct_byref
4975 EXPR is an actual argument. On exit, se->expr contains a
4976 pointer to the array descriptor.
4978 - !se->want_pointer && !se->direct_byref
4979 EXPR is an actual argument to an intrinsic function or the
4980 left-hand side of a pointer assignment. On exit, se->expr
4981 contains the descriptor for EXPR.
4983 - !se->want_pointer && se->direct_byref
4984 EXPR is the right-hand side of a pointer assignment and
4985 se->expr is the descriptor for the previously-evaluated
4986 left-hand side. The function creates an assignment from
4987 EXPR to se->expr. */
4990 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5003 bool subref_array_target = false;
5005 gcc_assert (ss != gfc_ss_terminator);
5007 /* Special case things we know we can pass easily. */
5008 switch (expr->expr_type)
5011 /* If we have a linear array section, we can pass it directly.
5012 Otherwise we need to copy it into a temporary. */
5014 /* Find the SS for the array section. */
5016 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5017 secss = secss->next;
5019 gcc_assert (secss != gfc_ss_terminator);
5020 info = &secss->data.info;
5022 /* Get the descriptor for the array. */
5023 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5024 desc = info->descriptor;
5026 subref_array_target = se->direct_byref && is_subref_array (expr);
5027 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5028 && !subref_array_target;
5032 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5034 /* Create a new descriptor if the array doesn't have one. */
5037 else if (info->ref->u.ar.type == AR_FULL)
5039 else if (se->direct_byref)
5042 full = gfc_full_array_ref_p (info->ref, NULL);
5046 if (se->direct_byref)
5048 /* Copy the descriptor for pointer assignments. */
5049 gfc_add_modify (&se->pre, se->expr, desc);
5051 /* Add any offsets from subreferences. */
5052 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5053 subref_array_target, expr);
5055 else if (se->want_pointer)
5057 /* We pass full arrays directly. This means that pointers and
5058 allocatable arrays should also work. */
5059 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5066 if (expr->ts.type == BT_CHARACTER)
5067 se->string_length = gfc_get_expr_charlen (expr);
5074 /* A transformational function return value will be a temporary
5075 array descriptor. We still need to go through the scalarizer
5076 to create the descriptor. Elemental functions ar handled as
5077 arbitrary expressions, i.e. copy to a temporary. */
5079 /* Look for the SS for this function. */
5080 while (secss != gfc_ss_terminator
5081 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5082 secss = secss->next;
5084 if (se->direct_byref)
5086 gcc_assert (secss != gfc_ss_terminator);
5088 /* For pointer assignments pass the descriptor directly. */
5090 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5091 gfc_conv_expr (se, expr);
5095 if (secss == gfc_ss_terminator)
5097 /* Elemental function. */
5099 if (expr->ts.type == BT_CHARACTER
5100 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5101 get_array_charlen (expr, se);
5107 /* Transformational function. */
5108 info = &secss->data.info;
5114 /* Constant array constructors don't need a temporary. */
5115 if (ss->type == GFC_SS_CONSTRUCTOR
5116 && expr->ts.type != BT_CHARACTER
5117 && gfc_constant_array_constructor_p (expr->value.constructor))
5120 info = &ss->data.info;
5132 /* Something complicated. Copy it into a temporary. */
5139 gfc_init_loopinfo (&loop);
5141 /* Associate the SS with the loop. */
5142 gfc_add_ss_to_loop (&loop, ss);
5144 /* Tell the scalarizer not to bother creating loop variables, etc. */
5146 loop.array_parameter = 1;
5148 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5149 gcc_assert (!se->direct_byref);
5151 /* Setup the scalarizing loops and bounds. */
5152 gfc_conv_ss_startstride (&loop);
5156 /* Tell the scalarizer to make a temporary. */
5157 loop.temp_ss = gfc_get_ss ();
5158 loop.temp_ss->type = GFC_SS_TEMP;
5159 loop.temp_ss->next = gfc_ss_terminator;
5161 if (expr->ts.type == BT_CHARACTER
5162 && !expr->ts.u.cl->backend_decl)
5163 get_array_charlen (expr, se);
5165 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5167 if (expr->ts.type == BT_CHARACTER)
5168 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5170 loop.temp_ss->string_length = NULL;
5172 se->string_length = loop.temp_ss->string_length;
5173 loop.temp_ss->data.temp.dimen = loop.dimen;
5174 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5177 gfc_conv_loop_setup (&loop, & expr->where);
5181 /* Copy into a temporary and pass that. We don't need to copy the data
5182 back because expressions and vector subscripts must be INTENT_IN. */
5183 /* TODO: Optimize passing function return values. */
5187 /* Start the copying loops. */
5188 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5189 gfc_mark_ss_chain_used (ss, 1);
5190 gfc_start_scalarized_body (&loop, &block);
5192 /* Copy each data element. */
5193 gfc_init_se (&lse, NULL);
5194 gfc_copy_loopinfo_to_se (&lse, &loop);
5195 gfc_init_se (&rse, NULL);
5196 gfc_copy_loopinfo_to_se (&rse, &loop);
5198 lse.ss = loop.temp_ss;
5201 gfc_conv_scalarized_array_ref (&lse, NULL);
5202 if (expr->ts.type == BT_CHARACTER)
5204 gfc_conv_expr (&rse, expr);
5205 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5206 rse.expr = build_fold_indirect_ref_loc (input_location,
5210 gfc_conv_expr_val (&rse, expr);
5212 gfc_add_block_to_block (&block, &rse.pre);
5213 gfc_add_block_to_block (&block, &lse.pre);
5215 lse.string_length = rse.string_length;
5216 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5217 expr->expr_type == EXPR_VARIABLE);
5218 gfc_add_expr_to_block (&block, tmp);
5220 /* Finish the copying loops. */
5221 gfc_trans_scalarizing_loops (&loop, &block);
5223 desc = loop.temp_ss->data.info.descriptor;
5225 gcc_assert (is_gimple_lvalue (desc));
5227 else if (expr->expr_type == EXPR_FUNCTION)
5229 desc = info->descriptor;
5230 se->string_length = ss->string_length;
5234 /* We pass sections without copying to a temporary. Make a new
5235 descriptor and point it at the section we want. The loop variable
5236 limits will be the limits of the section.
5237 A function may decide to repack the array to speed up access, but
5238 we're not bothered about that here. */
5247 /* Set the string_length for a character array. */
5248 if (expr->ts.type == BT_CHARACTER)
5249 se->string_length = gfc_get_expr_charlen (expr);
5251 desc = info->descriptor;
5252 gcc_assert (secss && secss != gfc_ss_terminator);
5253 if (se->direct_byref)
5255 /* For pointer assignments we fill in the destination. */
5257 parmtype = TREE_TYPE (parm);
5261 /* Otherwise make a new one. */
5262 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5263 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5264 loop.from, loop.to, 0,
5265 GFC_ARRAY_UNKNOWN, false);
5266 parm = gfc_create_var (parmtype, "parm");
5269 offset = gfc_index_zero_node;
5272 /* The following can be somewhat confusing. We have two
5273 descriptors, a new one and the original array.
5274 {parm, parmtype, dim} refer to the new one.
5275 {desc, type, n, secss, loop} refer to the original, which maybe
5276 a descriptorless array.
5277 The bounds of the scalarization are the bounds of the section.
5278 We don't have to worry about numeric overflows when calculating
5279 the offsets because all elements are within the array data. */
5281 /* Set the dtype. */
5282 tmp = gfc_conv_descriptor_dtype (parm);
5283 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5285 /* Set offset for assignments to pointer only to zero if it is not
5287 if (se->direct_byref
5288 && info->ref && info->ref->u.ar.type != AR_FULL)
5289 base = gfc_index_zero_node;
5290 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5291 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5295 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5296 for (n = 0; n < ndim; n++)
5298 stride = gfc_conv_array_stride (desc, n);
5300 /* Work out the offset. */
5302 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5304 gcc_assert (info->subscript[n]
5305 && info->subscript[n]->type == GFC_SS_SCALAR);
5306 start = info->subscript[n]->data.scalar.expr;
5310 /* Check we haven't somehow got out of sync. */
5311 gcc_assert (info->dim[dim] == n);
5313 /* Evaluate and remember the start of the section. */
5314 start = info->start[dim];
5315 stride = gfc_evaluate_now (stride, &loop.pre);
5318 tmp = gfc_conv_array_lbound (desc, n);
5319 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5321 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5322 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5325 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5327 /* For elemental dimensions, we only need the offset. */
5331 /* Vector subscripts need copying and are handled elsewhere. */
5333 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5335 /* Set the new lower bound. */
5336 from = loop.from[dim];
5339 /* If we have an array section or are assigning make sure that
5340 the lower bound is 1. References to the full
5341 array should otherwise keep the original bounds. */
5343 || info->ref->u.ar.type != AR_FULL)
5344 && !integer_onep (from))
5346 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5347 gfc_index_one_node, from);
5348 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5349 from = gfc_index_one_node;
5351 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5352 gfc_rank_cst[dim], from);
5354 /* Set the new upper bound. */
5355 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5356 gfc_rank_cst[dim], to);
5358 /* Multiply the stride by the section stride to get the
5360 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5361 stride, info->stride[dim]);
5363 if (se->direct_byref
5365 && info->ref->u.ar.type != AR_FULL)
5367 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5370 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5372 tmp = gfc_conv_array_lbound (desc, n);
5373 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5374 tmp, loop.from[dim]);
5375 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5376 tmp, gfc_conv_array_stride (desc, n));
5377 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5381 /* Store the new stride. */
5382 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5383 gfc_rank_cst[dim], stride);
5388 if (se->data_not_needed)
5389 gfc_conv_descriptor_data_set (&loop.pre, parm,
5390 gfc_index_zero_node);
5392 /* Point the data pointer at the 1st element in the section. */
5393 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5394 subref_array_target, expr);
5396 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5397 && !se->data_not_needed)
5399 /* Set the offset. */
5400 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5404 /* Only the callee knows what the correct offset it, so just set
5406 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5411 if (!se->direct_byref)
5413 /* Get a pointer to the new descriptor. */
5414 if (se->want_pointer)
5415 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5420 gfc_add_block_to_block (&se->pre, &loop.pre);
5421 gfc_add_block_to_block (&se->post, &loop.post);
5423 /* Cleanup the scalarizer. */
5424 gfc_cleanup_loop (&loop);
5427 /* Helper function for gfc_conv_array_parameter if array size needs to be
5431 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5434 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5435 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5436 else if (expr->rank > 1)
5437 *size = build_call_expr_loc (input_location,
5438 gfor_fndecl_size0, 1,
5439 gfc_build_addr_expr (NULL, desc));
5442 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5443 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5445 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5446 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5447 gfc_index_one_node);
5448 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5449 gfc_index_zero_node);
5451 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5452 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5453 fold_convert (gfc_array_index_type, elem));
5456 /* Convert an array for passing as an actual parameter. */
5457 /* TODO: Optimize passing g77 arrays. */
5460 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5461 const gfc_symbol *fsym, const char *proc_name,
5466 tree tmp = NULL_TREE;
5468 tree parent = DECL_CONTEXT (current_function_decl);
5469 bool full_array_var;
5470 bool this_array_result;
5473 bool array_constructor;
5474 bool good_allocatable;
5475 bool ultimate_ptr_comp;
5476 bool ultimate_alloc_comp;
5481 ultimate_ptr_comp = false;
5482 ultimate_alloc_comp = false;
5483 for (ref = expr->ref; ref; ref = ref->next)
5485 if (ref->next == NULL)
5488 if (ref->type == REF_COMPONENT)
5490 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5491 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5495 full_array_var = false;
5498 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5499 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5501 sym = full_array_var ? expr->symtree->n.sym : NULL;
5503 /* The symbol should have an array specification. */
5504 gcc_assert (!sym || sym->as || ref->u.ar.as);
5506 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5508 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5509 expr->ts.u.cl->backend_decl = tmp;
5510 se->string_length = tmp;
5513 /* Is this the result of the enclosing procedure? */
5514 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5515 if (this_array_result
5516 && (sym->backend_decl != current_function_decl)
5517 && (sym->backend_decl != parent))
5518 this_array_result = false;
5520 /* Passing address of the array if it is not pointer or assumed-shape. */
5521 if (full_array_var && g77 && !this_array_result)
5523 tmp = gfc_get_symbol_decl (sym);
5525 if (sym->ts.type == BT_CHARACTER)
5526 se->string_length = sym->ts.u.cl->backend_decl;
5528 if (sym->ts.type == BT_DERIVED)
5530 gfc_conv_expr_descriptor (se, expr, ss);
5531 se->expr = gfc_conv_array_data (se->expr);
5535 if (!sym->attr.pointer
5537 && sym->as->type != AS_ASSUMED_SHAPE
5538 && !sym->attr.allocatable)
5540 /* Some variables are declared directly, others are declared as
5541 pointers and allocated on the heap. */
5542 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5545 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5547 array_parameter_size (tmp, expr, size);
5551 if (sym->attr.allocatable)
5553 if (sym->attr.dummy || sym->attr.result)
5555 gfc_conv_expr_descriptor (se, expr, ss);
5559 array_parameter_size (tmp, expr, size);
5560 se->expr = gfc_conv_array_data (tmp);
5565 /* A convenient reduction in scope. */
5566 contiguous = g77 && !this_array_result && contiguous;
5568 /* There is no need to pack and unpack the array, if it is contiguous
5569 and not deferred or assumed shape. */
5570 no_pack = ((sym && sym->as
5571 && !sym->attr.pointer
5572 && sym->as->type != AS_DEFERRED
5573 && sym->as->type != AS_ASSUMED_SHAPE)
5575 (ref && ref->u.ar.as
5576 && ref->u.ar.as->type != AS_DEFERRED
5577 && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
5579 no_pack = contiguous && no_pack;
5581 /* Array constructors are always contiguous and do not need packing. */
5582 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5584 /* Same is true of contiguous sections from allocatable variables. */
5585 good_allocatable = contiguous
5587 && expr->symtree->n.sym->attr.allocatable;
5589 /* Or ultimate allocatable components. */
5590 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5592 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5594 gfc_conv_expr_descriptor (se, expr, ss);
5595 if (expr->ts.type == BT_CHARACTER)
5596 se->string_length = expr->ts.u.cl->backend_decl;
5598 array_parameter_size (se->expr, expr, size);
5599 se->expr = gfc_conv_array_data (se->expr);
5603 if (this_array_result)
5605 /* Result of the enclosing function. */
5606 gfc_conv_expr_descriptor (se, expr, ss);
5608 array_parameter_size (se->expr, expr, size);
5609 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5611 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5612 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5613 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5620 /* Every other type of array. */
5621 se->want_pointer = 1;
5622 gfc_conv_expr_descriptor (se, expr, ss);
5624 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5629 /* Deallocate the allocatable components of structures that are
5631 if (expr->ts.type == BT_DERIVED
5632 && expr->ts.u.derived->attr.alloc_comp
5633 && expr->expr_type != EXPR_VARIABLE)
5635 tmp = build_fold_indirect_ref_loc (input_location,
5637 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5638 gfc_add_expr_to_block (&se->post, tmp);
5644 /* Repack the array. */
5645 if (gfc_option.warn_array_temp)
5648 gfc_warning ("Creating array temporary at %L for argument '%s'",
5649 &expr->where, fsym->name);
5651 gfc_warning ("Creating array temporary at %L", &expr->where);
5654 ptr = build_call_expr_loc (input_location,
5655 gfor_fndecl_in_pack, 1, desc);
5657 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5659 tmp = gfc_conv_expr_present (sym);
5660 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5661 fold_convert (TREE_TYPE (se->expr), ptr),
5662 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5665 ptr = gfc_evaluate_now (ptr, &se->pre);
5669 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5673 if (fsym && proc_name)
5674 asprintf (&msg, "An array temporary was created for argument "
5675 "'%s' of procedure '%s'", fsym->name, proc_name);
5677 asprintf (&msg, "An array temporary was created");
5679 tmp = build_fold_indirect_ref_loc (input_location,
5681 tmp = gfc_conv_array_data (tmp);
5682 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5683 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5685 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5686 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5687 gfc_conv_expr_present (sym), tmp);
5689 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5694 gfc_start_block (&block);
5696 /* Copy the data back. */
5697 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5699 tmp = build_call_expr_loc (input_location,
5700 gfor_fndecl_in_unpack, 2, desc, ptr);
5701 gfc_add_expr_to_block (&block, tmp);
5704 /* Free the temporary. */
5705 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5706 gfc_add_expr_to_block (&block, tmp);
5708 stmt = gfc_finish_block (&block);
5710 gfc_init_block (&block);
5711 /* Only if it was repacked. This code needs to be executed before the
5712 loop cleanup code. */
5713 tmp = build_fold_indirect_ref_loc (input_location,
5715 tmp = gfc_conv_array_data (tmp);
5716 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5717 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5719 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5720 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5721 gfc_conv_expr_present (sym), tmp);
5723 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5725 gfc_add_expr_to_block (&block, tmp);
5726 gfc_add_block_to_block (&block, &se->post);
5728 gfc_init_block (&se->post);
5729 gfc_add_block_to_block (&se->post, &block);
5734 /* Generate code to deallocate an array, if it is allocated. */
5737 gfc_trans_dealloc_allocated (tree descriptor)
5743 gfc_start_block (&block);
5745 var = gfc_conv_descriptor_data_get (descriptor);
5748 /* Call array_deallocate with an int * present in the second argument.
5749 Although it is ignored here, it's presence ensures that arrays that
5750 are already deallocated are ignored. */
5751 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5752 gfc_add_expr_to_block (&block, tmp);
5754 /* Zero the data pointer. */
5755 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5756 var, build_int_cst (TREE_TYPE (var), 0));
5757 gfc_add_expr_to_block (&block, tmp);
5759 return gfc_finish_block (&block);
5763 /* This helper function calculates the size in words of a full array. */
5766 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5771 idx = gfc_rank_cst[rank - 1];
5772 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5773 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5774 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5775 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5776 tmp, gfc_index_one_node);
5777 tmp = gfc_evaluate_now (tmp, block);
5779 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5780 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5781 return gfc_evaluate_now (tmp, block);
5785 /* Allocate dest to the same size as src, and copy src -> dest.
5786 If no_malloc is set, only the copy is done. */
5789 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5799 /* If the source is null, set the destination to null. Then,
5800 allocate memory to the destination. */
5801 gfc_init_block (&block);
5805 tmp = null_pointer_node;
5806 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5807 gfc_add_expr_to_block (&block, tmp);
5808 null_data = gfc_finish_block (&block);
5810 gfc_init_block (&block);
5811 size = TYPE_SIZE_UNIT (type);
5814 tmp = gfc_call_malloc (&block, type, size);
5815 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5816 fold_convert (type, tmp));
5817 gfc_add_expr_to_block (&block, tmp);
5820 tmp = built_in_decls[BUILT_IN_MEMCPY];
5821 tmp = build_call_expr_loc (input_location, tmp, 3,
5826 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5827 null_data = gfc_finish_block (&block);
5829 gfc_init_block (&block);
5830 nelems = get_full_array_size (&block, src, rank);
5831 tmp = fold_convert (gfc_array_index_type,
5832 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5833 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5836 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5837 tmp = gfc_call_malloc (&block, tmp, size);
5838 gfc_conv_descriptor_data_set (&block, dest, tmp);
5841 /* We know the temporary and the value will be the same length,
5842 so can use memcpy. */
5843 tmp = built_in_decls[BUILT_IN_MEMCPY];
5844 tmp = build_call_expr_loc (input_location,
5845 tmp, 3, gfc_conv_descriptor_data_get (dest),
5846 gfc_conv_descriptor_data_get (src), size);
5849 gfc_add_expr_to_block (&block, tmp);
5850 tmp = gfc_finish_block (&block);
5852 /* Null the destination if the source is null; otherwise do
5853 the allocate and copy. */
5857 null_cond = gfc_conv_descriptor_data_get (src);
5859 null_cond = convert (pvoid_type_node, null_cond);
5860 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5861 null_cond, null_pointer_node);
5862 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5866 /* Allocate dest to the same size as src, and copy data src -> dest. */
5869 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5871 return duplicate_allocatable(dest, src, type, rank, false);
5875 /* Copy data src -> dest. */
5878 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5880 return duplicate_allocatable(dest, src, type, rank, true);
5884 /* Recursively traverse an object of derived type, generating code to
5885 deallocate, nullify or copy allocatable components. This is the work horse
5886 function for the functions named in this enum. */
5888 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5889 COPY_ONLY_ALLOC_COMP};
5892 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5893 tree dest, int rank, int purpose)
5897 stmtblock_t fnblock;
5898 stmtblock_t loopbody;
5908 tree null_cond = NULL_TREE;
5910 gfc_init_block (&fnblock);
5912 if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
5913 decl = build_fold_indirect_ref_loc (input_location,
5916 /* If this an array of derived types with allocatable components
5917 build a loop and recursively call this function. */
5918 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5919 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5921 tmp = gfc_conv_array_data (decl);
5922 var = build_fold_indirect_ref_loc (input_location,
5925 /* Get the number of elements - 1 and set the counter. */
5926 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5928 /* Use the descriptor for an allocatable array. Since this
5929 is a full array reference, we only need the descriptor
5930 information from dimension = rank. */
5931 tmp = get_full_array_size (&fnblock, decl, rank);
5932 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5933 tmp, gfc_index_one_node);
5935 null_cond = gfc_conv_descriptor_data_get (decl);
5936 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5937 build_int_cst (TREE_TYPE (null_cond), 0));
5941 /* Otherwise use the TYPE_DOMAIN information. */
5942 tmp = array_type_nelts (TREE_TYPE (decl));
5943 tmp = fold_convert (gfc_array_index_type, tmp);
5946 /* Remember that this is, in fact, the no. of elements - 1. */
5947 nelems = gfc_evaluate_now (tmp, &fnblock);
5948 index = gfc_create_var (gfc_array_index_type, "S");
5950 /* Build the body of the loop. */
5951 gfc_init_block (&loopbody);
5953 vref = gfc_build_array_ref (var, index, NULL);
5955 if (purpose == COPY_ALLOC_COMP)
5957 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
5959 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5960 gfc_add_expr_to_block (&fnblock, tmp);
5962 tmp = build_fold_indirect_ref_loc (input_location,
5963 gfc_conv_array_data (dest));
5964 dref = gfc_build_array_ref (tmp, index, NULL);
5965 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5967 else if (purpose == COPY_ONLY_ALLOC_COMP)
5969 tmp = build_fold_indirect_ref_loc (input_location,
5970 gfc_conv_array_data (dest));
5971 dref = gfc_build_array_ref (tmp, index, NULL);
5972 tmp = structure_alloc_comps (der_type, vref, dref, rank,
5976 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5978 gfc_add_expr_to_block (&loopbody, tmp);
5980 /* Build the loop and return. */
5981 gfc_init_loopinfo (&loop);
5983 loop.from[0] = gfc_index_zero_node;
5984 loop.loopvar[0] = index;
5985 loop.to[0] = nelems;
5986 gfc_trans_scalarizing_loops (&loop, &loopbody);
5987 gfc_add_block_to_block (&fnblock, &loop.pre);
5989 tmp = gfc_finish_block (&fnblock);
5990 if (null_cond != NULL_TREE)
5991 tmp = build3_v (COND_EXPR, null_cond, tmp,
5992 build_empty_stmt (input_location));
5997 /* Otherwise, act on the components or recursively call self to
5998 act on a chain of components. */
5999 for (c = der_type->components; c; c = c->next)
6001 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6002 && c->ts.u.derived->attr.alloc_comp;
6003 cdecl = c->backend_decl;
6004 ctype = TREE_TYPE (cdecl);
6008 case DEALLOCATE_ALLOC_COMP:
6009 /* Do not deallocate the components of ultimate pointer
6011 if (cmp_has_alloc_comps && !c->attr.pointer)
6013 comp = fold_build3 (COMPONENT_REF, ctype,
6014 decl, cdecl, NULL_TREE);
6015 rank = c->as ? c->as->rank : 0;
6016 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6018 gfc_add_expr_to_block (&fnblock, tmp);
6021 if (c->attr.allocatable && c->attr.dimension)
6023 comp = fold_build3 (COMPONENT_REF, ctype,
6024 decl, cdecl, NULL_TREE);
6025 tmp = gfc_trans_dealloc_allocated (comp);
6026 gfc_add_expr_to_block (&fnblock, tmp);
6028 else if (c->attr.allocatable)
6030 /* Allocatable scalar components. */
6031 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6033 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6034 gfc_add_expr_to_block (&fnblock, tmp);
6036 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6037 build_int_cst (TREE_TYPE (comp), 0));
6038 gfc_add_expr_to_block (&fnblock, tmp);
6040 else if (c->ts.type == BT_CLASS
6041 && c->ts.u.derived->components->attr.allocatable)
6043 /* Allocatable scalar CLASS components. */
6044 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6046 /* Add reference to '$data' component. */
6047 tmp = c->ts.u.derived->components->backend_decl;
6048 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6049 comp, tmp, NULL_TREE);
6051 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6052 gfc_add_expr_to_block (&fnblock, tmp);
6054 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6055 build_int_cst (TREE_TYPE (comp), 0));
6056 gfc_add_expr_to_block (&fnblock, tmp);
6060 case NULLIFY_ALLOC_COMP:
6061 if (c->attr.pointer)
6063 else if (c->attr.allocatable && c->attr.dimension)
6065 comp = fold_build3 (COMPONENT_REF, ctype,
6066 decl, cdecl, NULL_TREE);
6067 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6069 else if (c->attr.allocatable)
6071 /* Allocatable scalar components. */
6072 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6073 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6074 build_int_cst (TREE_TYPE (comp), 0));
6075 gfc_add_expr_to_block (&fnblock, tmp);
6077 else if (c->ts.type == BT_CLASS
6078 && c->ts.u.derived->components->attr.allocatable)
6080 /* Allocatable scalar CLASS components. */
6081 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6082 /* Add reference to '$data' component. */
6083 tmp = c->ts.u.derived->components->backend_decl;
6084 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6085 comp, tmp, NULL_TREE);
6086 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6087 build_int_cst (TREE_TYPE (comp), 0));
6088 gfc_add_expr_to_block (&fnblock, tmp);
6090 else if (cmp_has_alloc_comps)
6092 comp = fold_build3 (COMPONENT_REF, ctype,
6093 decl, cdecl, NULL_TREE);
6094 rank = c->as ? c->as->rank : 0;
6095 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6097 gfc_add_expr_to_block (&fnblock, tmp);
6101 case COPY_ALLOC_COMP:
6102 if (c->attr.pointer)
6105 /* We need source and destination components. */
6106 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6107 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6108 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6110 if (c->attr.allocatable && !cmp_has_alloc_comps)
6112 rank = c->as ? c->as->rank : 0;
6113 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6114 gfc_add_expr_to_block (&fnblock, tmp);
6117 if (cmp_has_alloc_comps)
6119 rank = c->as ? c->as->rank : 0;
6120 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6121 gfc_add_modify (&fnblock, dcmp, tmp);
6122 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6124 gfc_add_expr_to_block (&fnblock, tmp);
6134 return gfc_finish_block (&fnblock);
6137 /* Recursively traverse an object of derived type, generating code to
6138 nullify allocatable components. */
6141 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6143 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6144 NULLIFY_ALLOC_COMP);
6148 /* Recursively traverse an object of derived type, generating code to
6149 deallocate allocatable components. */
6152 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6154 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6155 DEALLOCATE_ALLOC_COMP);
6159 /* Recursively traverse an object of derived type, generating code to
6160 copy it and its allocatable components. */
6163 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6165 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6169 /* Recursively traverse an object of derived type, generating code to
6170 copy only its allocatable components. */
6173 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6175 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6179 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6180 Do likewise, recursively if necessary, with the allocatable components of
6184 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
6189 stmtblock_t fnblock;
6192 bool sym_has_alloc_comp;
6194 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6195 && sym->ts.u.derived->attr.alloc_comp;
6197 /* Make sure the frontend gets these right. */
6198 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6199 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6200 "allocatable attribute or derived type without allocatable "
6203 gfc_init_block (&fnblock);
6205 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6206 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6208 if (sym->ts.type == BT_CHARACTER
6209 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6211 gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
6212 gfc_trans_vla_type_sizes (sym, &fnblock);
6215 /* Dummy, use associated and result variables don't need anything special. */
6216 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6218 gfc_add_expr_to_block (&fnblock, body);
6220 return gfc_finish_block (&fnblock);
6223 gfc_get_backend_locus (&loc);
6224 gfc_set_backend_locus (&sym->declared_at);
6225 descriptor = sym->backend_decl;
6227 /* Although static, derived types with default initializers and
6228 allocatable components must not be nulled wholesale; instead they
6229 are treated component by component. */
6230 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6232 /* SAVEd variables are not freed on exit. */
6233 gfc_trans_static_array_pointer (sym);
6237 /* Get the descriptor type. */
6238 type = TREE_TYPE (sym->backend_decl);
6240 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6242 if (!sym->attr.save)
6244 rank = sym->as ? sym->as->rank : 0;
6245 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
6246 gfc_add_expr_to_block (&fnblock, tmp);
6249 tmp = gfc_init_default_dt (sym, NULL);
6250 gfc_add_expr_to_block (&fnblock, tmp);
6254 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6256 /* If the backend_decl is not a descriptor, we must have a pointer
6258 descriptor = build_fold_indirect_ref_loc (input_location,
6260 type = TREE_TYPE (descriptor);
6263 /* NULLIFY the data pointer. */
6264 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6265 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
6267 gfc_add_expr_to_block (&fnblock, body);
6269 gfc_set_backend_locus (&loc);
6271 /* Allocatable arrays need to be freed when they go out of scope.
6272 The allocatable components of pointers must not be touched. */
6273 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6274 && !sym->attr.pointer && !sym->attr.save)
6277 rank = sym->as ? sym->as->rank : 0;
6278 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6279 gfc_add_expr_to_block (&fnblock, tmp);
6282 if (sym->attr.allocatable && sym->attr.dimension
6283 && !sym->attr.save && !sym->attr.result)
6285 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6286 gfc_add_expr_to_block (&fnblock, tmp);
6289 return gfc_finish_block (&fnblock);
6292 /************ Expression Walking Functions ******************/
6294 /* Walk a variable reference.
6296 Possible extension - multiple component subscripts.
6297 x(:,:) = foo%a(:)%b(:)
6299 forall (i=..., j=...)
6300 x(i,j) = foo%a(j)%b(i)
6302 This adds a fair amount of complexity because you need to deal with more
6303 than one ref. Maybe handle in a similar manner to vector subscripts.
6304 Maybe not worth the effort. */
6308 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6315 for (ref = expr->ref; ref; ref = ref->next)
6316 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6319 for (; ref; ref = ref->next)
6321 if (ref->type == REF_SUBSTRING)
6323 newss = gfc_get_ss ();
6324 newss->type = GFC_SS_SCALAR;
6325 newss->expr = ref->u.ss.start;
6329 newss = gfc_get_ss ();
6330 newss->type = GFC_SS_SCALAR;
6331 newss->expr = ref->u.ss.end;
6336 /* We're only interested in array sections from now on. */
6337 if (ref->type != REF_ARRAY)
6344 for (n = 0; n < ar->dimen; n++)
6346 newss = gfc_get_ss ();
6347 newss->type = GFC_SS_SCALAR;
6348 newss->expr = ar->start[n];
6355 newss = gfc_get_ss ();
6356 newss->type = GFC_SS_SECTION;
6359 newss->data.info.dimen = ar->as->rank;
6360 newss->data.info.ref = ref;
6362 /* Make sure array is the same as array(:,:), this way
6363 we don't need to special case all the time. */
6364 ar->dimen = ar->as->rank;
6365 for (n = 0; n < ar->dimen; n++)
6367 newss->data.info.dim[n] = n;
6368 ar->dimen_type[n] = DIMEN_RANGE;
6370 gcc_assert (ar->start[n] == NULL);
6371 gcc_assert (ar->end[n] == NULL);
6372 gcc_assert (ar->stride[n] == NULL);
6378 newss = gfc_get_ss ();
6379 newss->type = GFC_SS_SECTION;
6382 newss->data.info.dimen = 0;
6383 newss->data.info.ref = ref;
6385 /* We add SS chains for all the subscripts in the section. */
6386 for (n = 0; n < ar->dimen; n++)
6390 switch (ar->dimen_type[n])
6393 /* Add SS for elemental (scalar) subscripts. */
6394 gcc_assert (ar->start[n]);
6395 indexss = gfc_get_ss ();
6396 indexss->type = GFC_SS_SCALAR;
6397 indexss->expr = ar->start[n];
6398 indexss->next = gfc_ss_terminator;
6399 indexss->loop_chain = gfc_ss_terminator;
6400 newss->data.info.subscript[n] = indexss;
6404 /* We don't add anything for sections, just remember this
6405 dimension for later. */
6406 newss->data.info.dim[newss->data.info.dimen] = n;
6407 newss->data.info.dimen++;
6411 /* Create a GFC_SS_VECTOR index in which we can store
6412 the vector's descriptor. */
6413 indexss = gfc_get_ss ();
6414 indexss->type = GFC_SS_VECTOR;
6415 indexss->expr = ar->start[n];
6416 indexss->next = gfc_ss_terminator;
6417 indexss->loop_chain = gfc_ss_terminator;
6418 newss->data.info.subscript[n] = indexss;
6419 newss->data.info.dim[newss->data.info.dimen] = n;
6420 newss->data.info.dimen++;
6424 /* We should know what sort of section it is by now. */
6428 /* We should have at least one non-elemental dimension. */
6429 gcc_assert (newss->data.info.dimen > 0);
6434 /* We should know what sort of section it is by now. */
6443 /* Walk an expression operator. If only one operand of a binary expression is
6444 scalar, we must also add the scalar term to the SS chain. */
6447 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6453 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6454 if (expr->value.op.op2 == NULL)
6457 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6459 /* All operands are scalar. Pass back and let the caller deal with it. */
6463 /* All operands require scalarization. */
6464 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6467 /* One of the operands needs scalarization, the other is scalar.
6468 Create a gfc_ss for the scalar expression. */
6469 newss = gfc_get_ss ();
6470 newss->type = GFC_SS_SCALAR;
6473 /* First operand is scalar. We build the chain in reverse order, so
6474 add the scalar SS after the second operand. */
6476 while (head && head->next != ss)
6478 /* Check we haven't somehow broken the chain. */
6482 newss->expr = expr->value.op.op1;
6484 else /* head2 == head */
6486 gcc_assert (head2 == head);
6487 /* Second operand is scalar. */
6488 newss->next = head2;
6490 newss->expr = expr->value.op.op2;
6497 /* Reverse a SS chain. */
6500 gfc_reverse_ss (gfc_ss * ss)
6505 gcc_assert (ss != NULL);
6507 head = gfc_ss_terminator;
6508 while (ss != gfc_ss_terminator)
6511 /* Check we didn't somehow break the chain. */
6512 gcc_assert (next != NULL);
6522 /* Walk the arguments of an elemental function. */
6525 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6533 head = gfc_ss_terminator;
6536 for (; arg; arg = arg->next)
6541 newss = gfc_walk_subexpr (head, arg->expr);
6544 /* Scalar argument. */
6545 newss = gfc_get_ss ();
6547 newss->expr = arg->expr;
6557 while (tail->next != gfc_ss_terminator)
6564 /* If all the arguments are scalar we don't need the argument SS. */
6565 gfc_free_ss_chain (head);
6570 /* Add it onto the existing chain. */
6576 /* Walk a function call. Scalar functions are passed back, and taken out of
6577 scalarization loops. For elemental functions we walk their arguments.
6578 The result of functions returning arrays is stored in a temporary outside
6579 the loop, so that the function is only called once. Hence we do not need
6580 to walk their arguments. */
6583 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6586 gfc_intrinsic_sym *isym;
6588 gfc_component *comp = NULL;
6590 isym = expr->value.function.isym;
6592 /* Handle intrinsic functions separately. */
6594 return gfc_walk_intrinsic_function (ss, expr, isym);
6596 sym = expr->value.function.esym;
6598 sym = expr->symtree->n.sym;
6600 /* A function that returns arrays. */
6601 gfc_is_proc_ptr_comp (expr, &comp);
6602 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6603 || (comp && comp->attr.dimension))
6605 newss = gfc_get_ss ();
6606 newss->type = GFC_SS_FUNCTION;
6609 newss->data.info.dimen = expr->rank;
6613 /* Walk the parameters of an elemental function. For now we always pass
6615 if (sym->attr.elemental)
6616 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6619 /* Scalar functions are OK as these are evaluated outside the scalarization
6620 loop. Pass back and let the caller deal with it. */
6625 /* An array temporary is constructed for array constructors. */
6628 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6633 newss = gfc_get_ss ();
6634 newss->type = GFC_SS_CONSTRUCTOR;
6637 newss->data.info.dimen = expr->rank;
6638 for (n = 0; n < expr->rank; n++)
6639 newss->data.info.dim[n] = n;
6645 /* Walk an expression. Add walked expressions to the head of the SS chain.
6646 A wholly scalar expression will not be added. */
6649 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6653 switch (expr->expr_type)
6656 head = gfc_walk_variable_expr (ss, expr);
6660 head = gfc_walk_op_expr (ss, expr);
6664 head = gfc_walk_function_expr (ss, expr);
6669 case EXPR_STRUCTURE:
6670 /* Pass back and let the caller deal with it. */
6674 head = gfc_walk_array_constructor (ss, expr);
6677 case EXPR_SUBSTRING:
6678 /* Pass back and let the caller deal with it. */
6682 internal_error ("bad expression type during walk (%d)",
6689 /* Entry point for expression walking.
6690 A return value equal to the passed chain means this is
6691 a scalar expression. It is up to the caller to take whatever action is
6692 necessary to translate these. */
6695 gfc_walk_expr (gfc_expr * expr)
6699 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6700 return gfc_reverse_ss (res);