1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var;
98 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
102 gfc_array_dataptr_type (tree desc)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc)
143 type = TREE_TYPE (desc);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
146 field = TYPE_FIELDS (type);
147 gcc_assert (DATA_FIELD == 0);
149 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 type = TREE_TYPE (desc);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172 field = TYPE_FIELDS (type);
173 gcc_assert (DATA_FIELD == 0);
175 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc)
189 type = TREE_TYPE (desc);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
192 field = TYPE_FIELDS (type);
193 gcc_assert (DATA_FIELD == 0);
195 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
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_loc (input_location, 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_loc (input_location, 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_loc (input_location, 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_loc (input_location, 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 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
292 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
293 return gfc_index_one_node;
295 return gfc_conv_descriptor_stride (desc, dim);
299 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
300 tree dim, tree value)
302 tree t = gfc_conv_descriptor_stride (desc, dim);
303 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
307 gfc_conv_descriptor_lbound (tree desc, tree dim)
312 tmp = gfc_conv_descriptor_dimension (desc, dim);
313 field = TYPE_FIELDS (TREE_TYPE (tmp));
314 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
315 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
317 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
318 tmp, field, NULL_TREE);
323 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
325 return gfc_conv_descriptor_lbound (desc, dim);
329 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
330 tree dim, tree value)
332 tree t = gfc_conv_descriptor_lbound (desc, dim);
333 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
337 gfc_conv_descriptor_ubound (tree desc, tree dim)
342 tmp = gfc_conv_descriptor_dimension (desc, dim);
343 field = TYPE_FIELDS (TREE_TYPE (tmp));
344 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
345 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
347 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
348 tmp, field, NULL_TREE);
353 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
355 return gfc_conv_descriptor_ubound (desc, dim);
359 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
360 tree dim, tree value)
362 tree t = gfc_conv_descriptor_ubound (desc, dim);
363 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
366 /* Build a null array descriptor constructor. */
369 gfc_build_null_descriptor (tree type)
374 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
375 gcc_assert (DATA_FIELD == 0);
376 field = TYPE_FIELDS (type);
378 /* Set a NULL data pointer. */
379 tmp = build_constructor_single (type, field, null_pointer_node);
380 TREE_CONSTANT (tmp) = 1;
381 /* All other fields are ignored. */
387 /* Modify a descriptor such that the lbound of a given dimension is the value
388 specified. This also updates ubound and offset accordingly. */
391 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
392 int dim, tree new_lbound)
394 tree offs, ubound, lbound, stride;
395 tree diff, offs_diff;
397 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
399 offs = gfc_conv_descriptor_offset_get (desc);
400 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
401 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
402 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
404 /* Get difference (new - old) by which to shift stuff. */
405 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
408 /* Shift ubound and offset accordingly. This has to be done before
409 updating the lbound, as they depend on the lbound expression! */
410 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
412 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
413 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
415 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
417 gfc_conv_descriptor_offset_set (block, desc, offs);
419 /* Finally set lbound to value we want. */
420 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
424 /* Cleanup those #defines. */
429 #undef DIMENSION_FIELD
430 #undef STRIDE_SUBFIELD
431 #undef LBOUND_SUBFIELD
432 #undef UBOUND_SUBFIELD
435 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
436 flags & 1 = Main loop body.
437 flags & 2 = temp copy loop. */
440 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
442 for (; ss != gfc_ss_terminator; ss = ss->next)
443 ss->useflags = flags;
446 static void gfc_free_ss (gfc_ss *);
449 /* Free a gfc_ss chain. */
452 gfc_free_ss_chain (gfc_ss * ss)
456 while (ss != gfc_ss_terminator)
458 gcc_assert (ss != NULL);
469 gfc_free_ss (gfc_ss * ss)
476 for (n = 0; n < ss->data.info.dimen; n++)
478 if (ss->data.info.subscript[ss->data.info.dim[n]])
479 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
491 /* Free all the SS associated with a loop. */
494 gfc_cleanup_loop (gfc_loopinfo * loop)
500 while (ss != gfc_ss_terminator)
502 gcc_assert (ss != NULL);
503 next = ss->loop_chain;
510 /* Associate a SS chain with a loop. */
513 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
517 if (head == gfc_ss_terminator)
521 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
523 if (ss->next == gfc_ss_terminator)
524 ss->loop_chain = loop->ss;
526 ss->loop_chain = ss->next;
528 gcc_assert (ss == gfc_ss_terminator);
533 /* Generate an initializer for a static pointer or allocatable array. */
536 gfc_trans_static_array_pointer (gfc_symbol * sym)
540 gcc_assert (TREE_STATIC (sym->backend_decl));
541 /* Just zero the data member. */
542 type = TREE_TYPE (sym->backend_decl);
543 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
547 /* If the bounds of SE's loop have not yet been set, see if they can be
548 determined from array spec AS, which is the array spec of a called
549 function. MAPPING maps the callee's dummy arguments to the values
550 that the caller is passing. Add any initialization and finalization
554 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
555 gfc_se * se, gfc_array_spec * as)
563 if (as && as->type == AS_EXPLICIT)
564 for (n = 0; n < se->loop->dimen; n++)
566 dim = se->ss->data.info.dim[n];
567 gcc_assert (dim < as->rank);
568 gcc_assert (se->loop->dimen == as->rank);
569 if (se->loop->to[n] == NULL_TREE)
571 /* Evaluate the lower bound. */
572 gfc_init_se (&tmpse, NULL);
573 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
574 gfc_add_block_to_block (&se->pre, &tmpse.pre);
575 gfc_add_block_to_block (&se->post, &tmpse.post);
576 lower = fold_convert (gfc_array_index_type, tmpse.expr);
578 /* ...and the upper bound. */
579 gfc_init_se (&tmpse, NULL);
580 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
581 gfc_add_block_to_block (&se->pre, &tmpse.pre);
582 gfc_add_block_to_block (&se->post, &tmpse.post);
583 upper = fold_convert (gfc_array_index_type, tmpse.expr);
585 /* Set the upper bound of the loop to UPPER - LOWER. */
586 tmp = fold_build2_loc (input_location, MINUS_EXPR,
587 gfc_array_index_type, upper, lower);
588 tmp = gfc_evaluate_now (tmp, &se->pre);
589 se->loop->to[n] = tmp;
595 /* Generate code to allocate an array temporary, or create a variable to
596 hold the data. If size is NULL, zero the descriptor so that the
597 callee will allocate the array. If DEALLOC is true, also generate code to
598 free the array afterwards.
600 If INITIAL is not NULL, it is packed using internal_pack and the result used
601 as data instead of allocating a fresh, unitialized area of memory.
603 Initialization code is added to PRE and finalization code to POST.
604 DYNAMIC is true if the caller may want to extend the array later
605 using realloc. This prevents us from putting the array on the stack. */
608 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
609 gfc_ss_info * info, tree size, tree nelem,
610 tree initial, bool dynamic, bool dealloc)
616 desc = info->descriptor;
617 info->offset = gfc_index_zero_node;
618 if (size == NULL_TREE || integer_zerop (size))
620 /* A callee allocated array. */
621 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
626 /* Allocate the temporary. */
627 onstack = !dynamic && initial == NULL_TREE
628 && gfc_can_put_var_on_stack (size);
632 /* Make a temporary variable to hold the data. */
633 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
634 nelem, gfc_index_one_node);
635 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
637 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
639 tmp = gfc_create_var (tmp, "A");
640 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
641 gfc_conv_descriptor_data_set (pre, desc, tmp);
645 /* Allocate memory to hold the data or call internal_pack. */
646 if (initial == NULL_TREE)
648 tmp = gfc_call_malloc (pre, NULL, size);
649 tmp = gfc_evaluate_now (tmp, pre);
656 stmtblock_t do_copying;
658 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
659 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
660 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
661 tmp = gfc_get_element_type (tmp);
662 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
663 packed = gfc_create_var (build_pointer_type (tmp), "data");
665 tmp = build_call_expr_loc (input_location,
666 gfor_fndecl_in_pack, 1, initial);
667 tmp = fold_convert (TREE_TYPE (packed), tmp);
668 gfc_add_modify (pre, packed, tmp);
670 tmp = build_fold_indirect_ref_loc (input_location,
672 source_data = gfc_conv_descriptor_data_get (tmp);
674 /* internal_pack may return source->data without any allocation
675 or copying if it is already packed. If that's the case, we
676 need to allocate and copy manually. */
678 gfc_start_block (&do_copying);
679 tmp = gfc_call_malloc (&do_copying, NULL, size);
680 tmp = fold_convert (TREE_TYPE (packed), tmp);
681 gfc_add_modify (&do_copying, packed, tmp);
682 tmp = gfc_build_memcpy_call (packed, source_data, size);
683 gfc_add_expr_to_block (&do_copying, tmp);
685 was_packed = fold_build2_loc (input_location, EQ_EXPR,
686 boolean_type_node, packed,
688 tmp = gfc_finish_block (&do_copying);
689 tmp = build3_v (COND_EXPR, was_packed, tmp,
690 build_empty_stmt (input_location));
691 gfc_add_expr_to_block (pre, tmp);
693 tmp = fold_convert (pvoid_type_node, packed);
696 gfc_conv_descriptor_data_set (pre, desc, tmp);
699 info->data = gfc_conv_descriptor_data_get (desc);
701 /* The offset is zero because we create temporaries with a zero
703 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
705 if (dealloc && !onstack)
707 /* Free the temporary. */
708 tmp = gfc_conv_descriptor_data_get (desc);
709 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
710 gfc_add_expr_to_block (post, tmp);
715 /* Get the array reference dimension corresponding to the given loop dimension.
716 It is different from the true array dimension given by the dim array in
717 the case of a partial array reference
718 It is different from the loop dimension in the case of a transposed array.
722 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
724 int n, array_dim, array_ref_dim;
727 array_dim = info->dim[loop_dim];
729 for (n = 0; n < info->dimen; n++)
730 if (n != loop_dim && info->dim[n] < array_dim)
733 return array_ref_dim;
737 /* Generate code to create and initialize the descriptor for a temporary
738 array. This is used for both temporaries needed by the scalarizer, and
739 functions returning arrays. Adjusts the loop variables to be
740 zero-based, and calculates the loop bounds for callee allocated arrays.
741 Allocate the array unless it's callee allocated (we have a callee
742 allocated array if 'callee_alloc' is true, or if loop->to[n] is
743 NULL_TREE for any n). Also fills in the descriptor, data and offset
744 fields of info if known. Returns the size of the array, or NULL for a
745 callee allocated array.
747 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
748 gfc_trans_allocate_array_storage.
752 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
753 gfc_loopinfo * loop, gfc_ss_info * info,
754 tree eltype, tree initial, bool dynamic,
755 bool dealloc, bool callee_alloc, locus * where)
757 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
767 memset (from, 0, sizeof (from));
768 memset (to, 0, sizeof (to));
770 gcc_assert (info->dimen > 0);
771 gcc_assert (loop->dimen == info->dimen);
773 if (gfc_option.warn_array_temp && where)
774 gfc_warning ("Creating array temporary at %L", where);
776 /* Set the lower bound to zero. */
777 for (n = 0; n < loop->dimen; n++)
781 /* Callee allocated arrays may not have a known bound yet. */
783 loop->to[n] = gfc_evaluate_now (
784 fold_build2_loc (input_location, MINUS_EXPR,
785 gfc_array_index_type,
786 loop->to[n], loop->from[n]),
788 loop->from[n] = gfc_index_zero_node;
790 /* We are constructing the temporary's descriptor based on the loop
791 dimensions. As the dimensions may be accessed in arbitrary order
792 (think of transpose) the size taken from the n'th loop may not map
793 to the n'th dimension of the array. We need to reconstruct loop infos
794 in the right order before using it to set the descriptor
796 tmp_dim = get_array_ref_dim (info, n);
797 from[tmp_dim] = loop->from[n];
798 to[tmp_dim] = loop->to[n];
800 info->delta[dim] = gfc_index_zero_node;
801 info->start[dim] = gfc_index_zero_node;
802 info->end[dim] = gfc_index_zero_node;
803 info->stride[dim] = gfc_index_one_node;
806 /* Initialize the descriptor. */
808 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
809 GFC_ARRAY_UNKNOWN, true);
810 desc = gfc_create_var (type, "atmp");
811 GFC_DECL_PACKED_ARRAY (desc) = 1;
813 info->descriptor = desc;
814 size = gfc_index_one_node;
816 /* Fill in the array dtype. */
817 tmp = gfc_conv_descriptor_dtype (desc);
818 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
821 Fill in the bounds and stride. This is a packed array, so:
824 for (n = 0; n < rank; n++)
827 delta = ubound[n] + 1 - lbound[n];
830 size = size * sizeof(element);
835 /* If there is at least one null loop->to[n], it is a callee allocated
837 for (n = 0; n < loop->dimen; n++)
838 if (loop->to[n] == NULL_TREE)
844 for (n = 0; n < loop->dimen; n++)
848 if (size == NULL_TREE)
850 /* For a callee allocated array express the loop bounds in terms
851 of the descriptor fields. */
852 tmp = fold_build2_loc (input_location,
853 MINUS_EXPR, gfc_array_index_type,
854 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
855 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
860 /* Store the stride and bound components in the descriptor. */
861 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
863 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
864 gfc_index_zero_node);
866 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
869 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
870 to[n], gfc_index_one_node);
872 /* Check whether the size for this dimension is negative. */
873 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
874 gfc_index_zero_node);
875 cond = gfc_evaluate_now (cond, pre);
880 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
881 boolean_type_node, or_expr, cond);
883 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
885 size = gfc_evaluate_now (size, pre);
888 /* Get the size of the array. */
890 if (size && !callee_alloc)
892 /* If or_expr is true, then the extent in at least one
893 dimension is zero and the size is set to zero. */
894 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
895 or_expr, gfc_index_zero_node, size);
898 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
900 fold_convert (gfc_array_index_type,
901 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
909 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
912 if (info->dimen > loop->temp_dim)
913 loop->temp_dim = info->dimen;
919 /* Return the number of iterations in a loop that starts at START,
920 ends at END, and has step STEP. */
923 gfc_get_iteration_count (tree start, tree end, tree step)
928 type = TREE_TYPE (step);
929 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
930 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
931 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
932 build_int_cst (type, 1));
933 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
934 build_int_cst (type, 0));
935 return fold_convert (gfc_array_index_type, tmp);
939 /* Extend the data in array DESC by EXTRA elements. */
942 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
949 if (integer_zerop (extra))
952 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
954 /* Add EXTRA to the upper bound. */
955 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
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_loc (input_location, PLUS_EXPR, gfc_array_index_type,
965 ubound, gfc_index_one_node);
966 arg1 = fold_build2_loc (input_location, 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_base base)
1025 mpz_set_ui (*size, 0);
1030 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1033 if (i && gfc_iterator_has_dynamic_bounds (i))
1037 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1040 /* Multiply the static part of the element size by the
1041 number of iterations. */
1042 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1043 mpz_fdiv_q (val, val, i->step->value.integer);
1044 mpz_add_ui (val, val, 1);
1045 if (mpz_sgn (val) > 0)
1046 mpz_mul (len, len, val);
1048 mpz_set_ui (len, 0);
1050 mpz_add (*size, *size, len);
1059 /* Make sure offset is a variable. */
1062 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1065 /* We should have already created the offset variable. We cannot
1066 create it here because we may be in an inner scope. */
1067 gcc_assert (*offsetvar != NULL_TREE);
1068 gfc_add_modify (pblock, *offsetvar, *poffset);
1069 *poffset = *offsetvar;
1070 TREE_USED (*offsetvar) = 1;
1074 /* Variables needed for bounds-checking. */
1075 static bool first_len;
1076 static tree first_len_val;
1077 static bool typespec_chararray_ctor;
1080 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1081 tree offset, gfc_se * se, gfc_expr * expr)
1085 gfc_conv_expr (se, expr);
1087 /* Store the value. */
1088 tmp = build_fold_indirect_ref_loc (input_location,
1089 gfc_conv_descriptor_data_get (desc));
1090 tmp = gfc_build_array_ref (tmp, offset, NULL);
1092 if (expr->ts.type == BT_CHARACTER)
1094 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1097 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1098 esize = fold_convert (gfc_charlen_type_node, esize);
1099 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1100 gfc_charlen_type_node, esize,
1101 build_int_cst (gfc_charlen_type_node,
1102 gfc_character_kinds[i].bit_size / 8));
1104 gfc_conv_string_parameter (se);
1105 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1107 /* The temporary is an array of pointers. */
1108 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1109 gfc_add_modify (&se->pre, tmp, se->expr);
1113 /* The temporary is an array of string values. */
1114 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1115 /* We know the temporary and the value will be the same length,
1116 so can use memcpy. */
1117 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1118 se->string_length, se->expr, expr->ts.kind);
1120 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1124 gfc_add_modify (&se->pre, first_len_val,
1130 /* Verify that all constructor elements are of the same
1132 tree cond = fold_build2_loc (input_location, NE_EXPR,
1133 boolean_type_node, first_len_val,
1135 gfc_trans_runtime_check
1136 (true, false, cond, &se->pre, &expr->where,
1137 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1138 fold_convert (long_integer_type_node, first_len_val),
1139 fold_convert (long_integer_type_node, se->string_length));
1145 /* TODO: Should the frontend already have done this conversion? */
1146 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1147 gfc_add_modify (&se->pre, tmp, se->expr);
1150 gfc_add_block_to_block (pblock, &se->pre);
1151 gfc_add_block_to_block (pblock, &se->post);
1155 /* Add the contents of an array to the constructor. DYNAMIC is as for
1156 gfc_trans_array_constructor_value. */
1159 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1160 tree type ATTRIBUTE_UNUSED,
1161 tree desc, gfc_expr * expr,
1162 tree * poffset, tree * offsetvar,
1173 /* We need this to be a variable so we can increment it. */
1174 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1176 gfc_init_se (&se, NULL);
1178 /* Walk the array expression. */
1179 ss = gfc_walk_expr (expr);
1180 gcc_assert (ss != gfc_ss_terminator);
1182 /* Initialize the scalarizer. */
1183 gfc_init_loopinfo (&loop);
1184 gfc_add_ss_to_loop (&loop, ss);
1186 /* Initialize the loop. */
1187 gfc_conv_ss_startstride (&loop);
1188 gfc_conv_loop_setup (&loop, &expr->where);
1190 /* Make sure the constructed array has room for the new data. */
1193 /* Set SIZE to the total number of elements in the subarray. */
1194 size = gfc_index_one_node;
1195 for (n = 0; n < loop.dimen; n++)
1197 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1198 gfc_index_one_node);
1199 size = fold_build2_loc (input_location, MULT_EXPR,
1200 gfc_array_index_type, size, tmp);
1203 /* Grow the constructed array by SIZE elements. */
1204 gfc_grow_array (&loop.pre, desc, size);
1207 /* Make the loop body. */
1208 gfc_mark_ss_chain_used (ss, 1);
1209 gfc_start_scalarized_body (&loop, &body);
1210 gfc_copy_loopinfo_to_se (&se, &loop);
1213 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1214 gcc_assert (se.ss == gfc_ss_terminator);
1216 /* Increment the offset. */
1217 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1218 *poffset, gfc_index_one_node);
1219 gfc_add_modify (&body, *poffset, tmp);
1221 /* Finish the loop. */
1222 gfc_trans_scalarizing_loops (&loop, &body);
1223 gfc_add_block_to_block (&loop.pre, &loop.post);
1224 tmp = gfc_finish_block (&loop.pre);
1225 gfc_add_expr_to_block (pblock, tmp);
1227 gfc_cleanup_loop (&loop);
1231 /* Assign the values to the elements of an array constructor. DYNAMIC
1232 is true if descriptor DESC only contains enough data for the static
1233 size calculated by gfc_get_array_constructor_size. When true, memory
1234 for the dynamic parts must be allocated using realloc. */
1237 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1238 tree desc, gfc_constructor_base base,
1239 tree * poffset, tree * offsetvar,
1248 tree shadow_loopvar = NULL_TREE;
1249 gfc_saved_var saved_loopvar;
1252 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1254 /* If this is an iterator or an array, the offset must be a variable. */
1255 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1256 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1258 /* Shadowing the iterator avoids changing its value and saves us from
1259 keeping track of it. Further, it makes sure that there's always a
1260 backend-decl for the symbol, even if there wasn't one before,
1261 e.g. in the case of an iterator that appears in a specification
1262 expression in an interface mapping. */
1265 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1266 tree type = gfc_typenode_for_spec (&sym->ts);
1268 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1269 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1272 gfc_start_block (&body);
1274 if (c->expr->expr_type == EXPR_ARRAY)
1276 /* Array constructors can be nested. */
1277 gfc_trans_array_constructor_value (&body, type, desc,
1278 c->expr->value.constructor,
1279 poffset, offsetvar, dynamic);
1281 else if (c->expr->rank > 0)
1283 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1284 poffset, offsetvar, dynamic);
1288 /* This code really upsets the gimplifier so don't bother for now. */
1295 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1297 p = gfc_constructor_next (p);
1302 /* Scalar values. */
1303 gfc_init_se (&se, NULL);
1304 gfc_trans_array_ctor_element (&body, desc, *poffset,
1307 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1308 gfc_array_index_type,
1309 *poffset, gfc_index_one_node);
1313 /* Collect multiple scalar constants into a constructor. */
1314 VEC(constructor_elt,gc) *v = NULL;
1318 HOST_WIDE_INT idx = 0;
1321 /* Count the number of consecutive scalar constants. */
1322 while (p && !(p->iterator
1323 || p->expr->expr_type != EXPR_CONSTANT))
1325 gfc_init_se (&se, NULL);
1326 gfc_conv_constant (&se, p->expr);
1328 if (c->expr->ts.type != BT_CHARACTER)
1329 se.expr = fold_convert (type, se.expr);
1330 /* For constant character array constructors we build
1331 an array of pointers. */
1332 else if (POINTER_TYPE_P (type))
1333 se.expr = gfc_build_addr_expr
1334 (gfc_get_pchar_type (p->expr->ts.kind),
1337 CONSTRUCTOR_APPEND_ELT (v,
1338 build_int_cst (gfc_array_index_type,
1342 p = gfc_constructor_next (p);
1345 bound = build_int_cst (NULL_TREE, n - 1);
1346 /* Create an array type to hold them. */
1347 tmptype = build_range_type (gfc_array_index_type,
1348 gfc_index_zero_node, bound);
1349 tmptype = build_array_type (type, tmptype);
1351 init = build_constructor (tmptype, v);
1352 TREE_CONSTANT (init) = 1;
1353 TREE_STATIC (init) = 1;
1354 /* Create a static variable to hold the data. */
1355 tmp = gfc_create_var (tmptype, "data");
1356 TREE_STATIC (tmp) = 1;
1357 TREE_CONSTANT (tmp) = 1;
1358 TREE_READONLY (tmp) = 1;
1359 DECL_INITIAL (tmp) = init;
1362 /* Use BUILTIN_MEMCPY to assign the values. */
1363 tmp = gfc_conv_descriptor_data_get (desc);
1364 tmp = build_fold_indirect_ref_loc (input_location,
1366 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1367 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1368 init = gfc_build_addr_expr (NULL_TREE, init);
1370 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1371 bound = build_int_cst (NULL_TREE, n * size);
1372 tmp = build_call_expr_loc (input_location,
1373 built_in_decls[BUILT_IN_MEMCPY], 3,
1375 gfc_add_expr_to_block (&body, tmp);
1377 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1378 gfc_array_index_type, *poffset,
1379 build_int_cst (gfc_array_index_type, n));
1381 if (!INTEGER_CST_P (*poffset))
1383 gfc_add_modify (&body, *offsetvar, *poffset);
1384 *poffset = *offsetvar;
1388 /* The frontend should already have done any expansions
1392 /* Pass the code as is. */
1393 tmp = gfc_finish_block (&body);
1394 gfc_add_expr_to_block (pblock, tmp);
1398 /* Build the implied do-loop. */
1399 stmtblock_t implied_do_block;
1407 loopbody = gfc_finish_block (&body);
1409 /* Create a new block that holds the implied-do loop. A temporary
1410 loop-variable is used. */
1411 gfc_start_block(&implied_do_block);
1413 /* Initialize the loop. */
1414 gfc_init_se (&se, NULL);
1415 gfc_conv_expr_val (&se, c->iterator->start);
1416 gfc_add_block_to_block (&implied_do_block, &se.pre);
1417 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1419 gfc_init_se (&se, NULL);
1420 gfc_conv_expr_val (&se, c->iterator->end);
1421 gfc_add_block_to_block (&implied_do_block, &se.pre);
1422 end = gfc_evaluate_now (se.expr, &implied_do_block);
1424 gfc_init_se (&se, NULL);
1425 gfc_conv_expr_val (&se, c->iterator->step);
1426 gfc_add_block_to_block (&implied_do_block, &se.pre);
1427 step = gfc_evaluate_now (se.expr, &implied_do_block);
1429 /* If this array expands dynamically, and the number of iterations
1430 is not constant, we won't have allocated space for the static
1431 part of C->EXPR's size. Do that now. */
1432 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1434 /* Get the number of iterations. */
1435 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1437 /* Get the static part of C->EXPR's size. */
1438 gfc_get_array_constructor_element_size (&size, c->expr);
1439 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1441 /* Grow the array by TMP * TMP2 elements. */
1442 tmp = fold_build2_loc (input_location, MULT_EXPR,
1443 gfc_array_index_type, tmp, tmp2);
1444 gfc_grow_array (&implied_do_block, desc, tmp);
1447 /* Generate the loop body. */
1448 exit_label = gfc_build_label_decl (NULL_TREE);
1449 gfc_start_block (&body);
1451 /* Generate the exit condition. Depending on the sign of
1452 the step variable we have to generate the correct
1454 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1455 step, build_int_cst (TREE_TYPE (step), 0));
1456 cond = fold_build3_loc (input_location, COND_EXPR,
1457 boolean_type_node, tmp,
1458 fold_build2_loc (input_location, GT_EXPR,
1459 boolean_type_node, shadow_loopvar, end),
1460 fold_build2_loc (input_location, LT_EXPR,
1461 boolean_type_node, shadow_loopvar, end));
1462 tmp = build1_v (GOTO_EXPR, exit_label);
1463 TREE_USED (exit_label) = 1;
1464 tmp = build3_v (COND_EXPR, cond, tmp,
1465 build_empty_stmt (input_location));
1466 gfc_add_expr_to_block (&body, tmp);
1468 /* The main loop body. */
1469 gfc_add_expr_to_block (&body, loopbody);
1471 /* Increase loop variable by step. */
1472 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1473 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1475 gfc_add_modify (&body, shadow_loopvar, tmp);
1477 /* Finish the loop. */
1478 tmp = gfc_finish_block (&body);
1479 tmp = build1_v (LOOP_EXPR, tmp);
1480 gfc_add_expr_to_block (&implied_do_block, tmp);
1482 /* Add the exit label. */
1483 tmp = build1_v (LABEL_EXPR, exit_label);
1484 gfc_add_expr_to_block (&implied_do_block, tmp);
1486 /* Finishe the implied-do loop. */
1487 tmp = gfc_finish_block(&implied_do_block);
1488 gfc_add_expr_to_block(pblock, tmp);
1490 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1497 /* Figure out the string length of a variable reference expression.
1498 Used by get_array_ctor_strlen. */
1501 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1507 /* Don't bother if we already know the length is a constant. */
1508 if (*len && INTEGER_CST_P (*len))
1511 ts = &expr->symtree->n.sym->ts;
1512 for (ref = expr->ref; ref; ref = ref->next)
1517 /* Array references don't change the string length. */
1521 /* Use the length of the component. */
1522 ts = &ref->u.c.component->ts;
1526 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1527 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1529 mpz_init_set_ui (char_len, 1);
1530 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1531 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1532 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1533 *len = convert (gfc_charlen_type_node, *len);
1534 mpz_clear (char_len);
1538 /* TODO: Substrings are tricky because we can't evaluate the
1539 expression more than once. For now we just give up, and hope
1540 we can figure it out elsewhere. */
1545 *len = ts->u.cl->backend_decl;
1549 /* A catch-all to obtain the string length for anything that is not a
1550 constant, array or variable. */
1552 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1557 /* Don't bother if we already know the length is a constant. */
1558 if (*len && INTEGER_CST_P (*len))
1561 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1562 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1565 gfc_conv_const_charlen (e->ts.u.cl);
1566 *len = e->ts.u.cl->backend_decl;
1570 /* Otherwise, be brutal even if inefficient. */
1571 ss = gfc_walk_expr (e);
1572 gfc_init_se (&se, NULL);
1574 /* No function call, in case of side effects. */
1575 se.no_function_call = 1;
1576 if (ss == gfc_ss_terminator)
1577 gfc_conv_expr (&se, e);
1579 gfc_conv_expr_descriptor (&se, e, ss);
1581 /* Fix the value. */
1582 *len = gfc_evaluate_now (se.string_length, &se.pre);
1584 gfc_add_block_to_block (block, &se.pre);
1585 gfc_add_block_to_block (block, &se.post);
1587 e->ts.u.cl->backend_decl = *len;
1592 /* Figure out the string length of a character array constructor.
1593 If len is NULL, don't calculate the length; this happens for recursive calls
1594 when a sub-array-constructor is an element but not at the first position,
1595 so when we're not interested in the length.
1596 Returns TRUE if all elements are character constants. */
1599 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1606 if (gfc_constructor_first (base) == NULL)
1609 *len = build_int_cstu (gfc_charlen_type_node, 0);
1613 /* Loop over all constructor elements to find out is_const, but in len we
1614 want to store the length of the first, not the last, element. We can
1615 of course exit the loop as soon as is_const is found to be false. */
1616 for (c = gfc_constructor_first (base);
1617 c && is_const; c = gfc_constructor_next (c))
1619 switch (c->expr->expr_type)
1622 if (len && !(*len && INTEGER_CST_P (*len)))
1623 *len = build_int_cstu (gfc_charlen_type_node,
1624 c->expr->value.character.length);
1628 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1635 get_array_ctor_var_strlen (c->expr, len);
1641 get_array_ctor_all_strlen (block, c->expr, len);
1645 /* After the first iteration, we don't want the length modified. */
1652 /* Check whether the array constructor C consists entirely of constant
1653 elements, and if so returns the number of those elements, otherwise
1654 return zero. Note, an empty or NULL array constructor returns zero. */
1656 unsigned HOST_WIDE_INT
1657 gfc_constant_array_constructor_p (gfc_constructor_base base)
1659 unsigned HOST_WIDE_INT nelem = 0;
1661 gfc_constructor *c = gfc_constructor_first (base);
1665 || c->expr->rank > 0
1666 || c->expr->expr_type != EXPR_CONSTANT)
1668 c = gfc_constructor_next (c);
1675 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1676 and the tree type of it's elements, TYPE, return a static constant
1677 variable that is compile-time initialized. */
1680 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1682 tree tmptype, init, tmp;
1683 HOST_WIDE_INT nelem;
1688 VEC(constructor_elt,gc) *v = NULL;
1690 /* First traverse the constructor list, converting the constants
1691 to tree to build an initializer. */
1693 c = gfc_constructor_first (expr->value.constructor);
1696 gfc_init_se (&se, NULL);
1697 gfc_conv_constant (&se, c->expr);
1698 if (c->expr->ts.type != BT_CHARACTER)
1699 se.expr = fold_convert (type, se.expr);
1700 else if (POINTER_TYPE_P (type))
1701 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1703 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1705 c = gfc_constructor_next (c);
1709 /* Next determine the tree type for the array. We use the gfortran
1710 front-end's gfc_get_nodesc_array_type in order to create a suitable
1711 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1713 memset (&as, 0, sizeof (gfc_array_spec));
1715 as.rank = expr->rank;
1716 as.type = AS_EXPLICIT;
1719 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1720 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1724 for (i = 0; i < expr->rank; i++)
1726 int tmp = (int) mpz_get_si (expr->shape[i]);
1727 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1728 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1732 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1734 /* as is not needed anymore. */
1735 for (i = 0; i < as.rank + as.corank; i++)
1737 gfc_free_expr (as.lower[i]);
1738 gfc_free_expr (as.upper[i]);
1741 init = build_constructor (tmptype, v);
1743 TREE_CONSTANT (init) = 1;
1744 TREE_STATIC (init) = 1;
1746 tmp = gfc_create_var (tmptype, "A");
1747 TREE_STATIC (tmp) = 1;
1748 TREE_CONSTANT (tmp) = 1;
1749 TREE_READONLY (tmp) = 1;
1750 DECL_INITIAL (tmp) = init;
1756 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1757 This mostly initializes the scalarizer state info structure with the
1758 appropriate values to directly use the array created by the function
1759 gfc_build_constant_array_constructor. */
1762 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1763 gfc_ss * ss, tree type)
1769 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1771 info = &ss->data.info;
1773 info->descriptor = tmp;
1774 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1775 info->offset = gfc_index_zero_node;
1777 for (i = 0; i < info->dimen; i++)
1779 info->delta[i] = gfc_index_zero_node;
1780 info->start[i] = gfc_index_zero_node;
1781 info->end[i] = gfc_index_zero_node;
1782 info->stride[i] = gfc_index_one_node;
1786 if (info->dimen > loop->temp_dim)
1787 loop->temp_dim = info->dimen;
1790 /* Helper routine of gfc_trans_array_constructor to determine if the
1791 bounds of the loop specified by LOOP are constant and simple enough
1792 to use with gfc_trans_constant_array_constructor. Returns the
1793 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1796 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1798 tree size = gfc_index_one_node;
1802 for (i = 0; i < loop->dimen; i++)
1804 /* If the bounds aren't constant, return NULL_TREE. */
1805 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1807 if (!integer_zerop (loop->from[i]))
1809 /* Only allow nonzero "from" in one-dimensional arrays. */
1810 if (loop->dimen != 1)
1812 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1813 gfc_array_index_type,
1814 loop->to[i], loop->from[i]);
1818 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1819 tmp, gfc_index_one_node);
1820 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1828 /* Array constructors are handled by constructing a temporary, then using that
1829 within the scalarization loop. This is not optimal, but seems by far the
1833 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1835 gfc_constructor_base c;
1842 bool old_first_len, old_typespec_chararray_ctor;
1843 tree old_first_len_val;
1845 /* Save the old values for nested checking. */
1846 old_first_len = first_len;
1847 old_first_len_val = first_len_val;
1848 old_typespec_chararray_ctor = typespec_chararray_ctor;
1850 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1851 typespec was given for the array constructor. */
1852 typespec_chararray_ctor = (ss->expr->ts.u.cl
1853 && ss->expr->ts.u.cl->length_from_typespec);
1855 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1856 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1858 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1862 ss->data.info.dimen = loop->dimen;
1864 c = ss->expr->value.constructor;
1865 if (ss->expr->ts.type == BT_CHARACTER)
1869 /* get_array_ctor_strlen walks the elements of the constructor, if a
1870 typespec was given, we already know the string length and want the one
1872 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1873 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1877 const_string = false;
1878 gfc_init_se (&length_se, NULL);
1879 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1880 gfc_charlen_type_node);
1881 ss->string_length = length_se.expr;
1882 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1883 gfc_add_block_to_block (&loop->post, &length_se.post);
1886 const_string = get_array_ctor_strlen (&loop->pre, c,
1887 &ss->string_length);
1889 /* Complex character array constructors should have been taken care of
1890 and not end up here. */
1891 gcc_assert (ss->string_length);
1893 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1895 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1897 type = build_pointer_type (type);
1900 type = gfc_typenode_for_spec (&ss->expr->ts);
1902 /* See if the constructor determines the loop bounds. */
1905 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1907 /* We have a multidimensional parameter. */
1909 for (n = 0; n < ss->expr->rank; n++)
1911 loop->from[n] = gfc_index_zero_node;
1912 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1913 gfc_index_integer_kind);
1914 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1915 gfc_array_index_type,
1916 loop->to[n], gfc_index_one_node);
1920 if (loop->to[0] == NULL_TREE)
1924 /* We should have a 1-dimensional, zero-based loop. */
1925 gcc_assert (loop->dimen == 1);
1926 gcc_assert (integer_zerop (loop->from[0]));
1928 /* Split the constructor size into a static part and a dynamic part.
1929 Allocate the static size up-front and record whether the dynamic
1930 size might be nonzero. */
1932 dynamic = gfc_get_array_constructor_size (&size, c);
1933 mpz_sub_ui (size, size, 1);
1934 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1938 /* Special case constant array constructors. */
1941 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1944 tree size = constant_array_constructor_loop_size (loop);
1945 if (size && compare_tree_int (size, nelem) == 0)
1947 gfc_trans_constant_array_constructor (loop, ss, type);
1953 if (TREE_CODE (loop->to[0]) == VAR_DECL)
1956 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1957 type, NULL_TREE, dynamic, true, false, where);
1959 desc = ss->data.info.descriptor;
1960 offset = gfc_index_zero_node;
1961 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1962 TREE_NO_WARNING (offsetvar) = 1;
1963 TREE_USED (offsetvar) = 0;
1964 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1965 &offset, &offsetvar, dynamic);
1967 /* If the array grows dynamically, the upper bound of the loop variable
1968 is determined by the array's final upper bound. */
1971 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1972 gfc_array_index_type,
1973 offsetvar, gfc_index_one_node);
1974 tmp = gfc_evaluate_now (tmp, &loop->pre);
1975 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
1976 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
1977 gfc_add_modify (&loop->pre, loop->to[0], tmp);
1982 if (TREE_USED (offsetvar))
1983 pushdecl (offsetvar);
1985 gcc_assert (INTEGER_CST_P (offset));
1988 /* Disable bound checking for now because it's probably broken. */
1989 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1996 /* Restore old values of globals. */
1997 first_len = old_first_len;
1998 first_len_val = old_first_len_val;
1999 typespec_chararray_ctor = old_typespec_chararray_ctor;
2003 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2004 called after evaluating all of INFO's vector dimensions. Go through
2005 each such vector dimension and see if we can now fill in any missing
2009 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2018 for (n = 0; n < loop->dimen; n++)
2021 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2022 && loop->to[n] == NULL)
2024 /* Loop variable N indexes vector dimension DIM, and we don't
2025 yet know the upper bound of loop variable N. Set it to the
2026 difference between the vector's upper and lower bounds. */
2027 gcc_assert (loop->from[n] == gfc_index_zero_node);
2028 gcc_assert (info->subscript[dim]
2029 && info->subscript[dim]->type == GFC_SS_VECTOR);
2031 gfc_init_se (&se, NULL);
2032 desc = info->subscript[dim]->data.info.descriptor;
2033 zero = gfc_rank_cst[0];
2034 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2035 gfc_array_index_type,
2036 gfc_conv_descriptor_ubound_get (desc, zero),
2037 gfc_conv_descriptor_lbound_get (desc, zero));
2038 tmp = gfc_evaluate_now (tmp, &loop->pre);
2045 /* Add the pre and post chains for all the scalar expressions in a SS chain
2046 to loop. This is called after the loop parameters have been calculated,
2047 but before the actual scalarizing loops. */
2050 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2056 /* TODO: This can generate bad code if there are ordering dependencies,
2057 e.g., a callee allocated function and an unknown size constructor. */
2058 gcc_assert (ss != NULL);
2060 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2067 /* Scalar expression. Evaluate this now. This includes elemental
2068 dimension indices, but not array section bounds. */
2069 gfc_init_se (&se, NULL);
2070 gfc_conv_expr (&se, ss->expr);
2071 gfc_add_block_to_block (&loop->pre, &se.pre);
2073 if (ss->expr->ts.type != BT_CHARACTER)
2075 /* Move the evaluation of scalar expressions outside the
2076 scalarization loop, except for WHERE assignments. */
2078 se.expr = convert(gfc_array_index_type, se.expr);
2080 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2081 gfc_add_block_to_block (&loop->pre, &se.post);
2084 gfc_add_block_to_block (&loop->post, &se.post);
2086 ss->data.scalar.expr = se.expr;
2087 ss->string_length = se.string_length;
2090 case GFC_SS_REFERENCE:
2091 /* Scalar argument to elemental procedure. Evaluate this
2093 gfc_init_se (&se, NULL);
2094 gfc_conv_expr (&se, ss->expr);
2095 gfc_add_block_to_block (&loop->pre, &se.pre);
2096 gfc_add_block_to_block (&loop->post, &se.post);
2098 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2099 ss->string_length = se.string_length;
2102 case GFC_SS_SECTION:
2103 /* Add the expressions for scalar and vector subscripts. */
2104 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2105 if (ss->data.info.subscript[n])
2106 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2109 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2113 /* Get the vector's descriptor and store it in SS. */
2114 gfc_init_se (&se, NULL);
2115 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2116 gfc_add_block_to_block (&loop->pre, &se.pre);
2117 gfc_add_block_to_block (&loop->post, &se.post);
2118 ss->data.info.descriptor = se.expr;
2121 case GFC_SS_INTRINSIC:
2122 gfc_add_intrinsic_ss_code (loop, ss);
2125 case GFC_SS_FUNCTION:
2126 /* Array function return value. We call the function and save its
2127 result in a temporary for use inside the loop. */
2128 gfc_init_se (&se, NULL);
2131 gfc_conv_expr (&se, ss->expr);
2132 gfc_add_block_to_block (&loop->pre, &se.pre);
2133 gfc_add_block_to_block (&loop->post, &se.post);
2134 ss->string_length = se.string_length;
2137 case GFC_SS_CONSTRUCTOR:
2138 if (ss->expr->ts.type == BT_CHARACTER
2139 && ss->string_length == NULL
2140 && ss->expr->ts.u.cl
2141 && ss->expr->ts.u.cl->length)
2143 gfc_init_se (&se, NULL);
2144 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2145 gfc_charlen_type_node);
2146 ss->string_length = se.expr;
2147 gfc_add_block_to_block (&loop->pre, &se.pre);
2148 gfc_add_block_to_block (&loop->post, &se.post);
2150 gfc_trans_array_constructor (loop, ss, where);
2154 case GFC_SS_COMPONENT:
2155 /* Do nothing. These are handled elsewhere. */
2165 /* Translate expressions for the descriptor and data pointer of a SS. */
2169 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2174 /* Get the descriptor for the array to be scalarized. */
2175 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2176 gfc_init_se (&se, NULL);
2177 se.descriptor_only = 1;
2178 gfc_conv_expr_lhs (&se, ss->expr);
2179 gfc_add_block_to_block (block, &se.pre);
2180 ss->data.info.descriptor = se.expr;
2181 ss->string_length = se.string_length;
2185 /* Also the data pointer. */
2186 tmp = gfc_conv_array_data (se.expr);
2187 /* If this is a variable or address of a variable we use it directly.
2188 Otherwise we must evaluate it now to avoid breaking dependency
2189 analysis by pulling the expressions for elemental array indices
2192 || (TREE_CODE (tmp) == ADDR_EXPR
2193 && DECL_P (TREE_OPERAND (tmp, 0)))))
2194 tmp = gfc_evaluate_now (tmp, block);
2195 ss->data.info.data = tmp;
2197 tmp = gfc_conv_array_offset (se.expr);
2198 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2200 /* Make absolutely sure that the saved_offset is indeed saved
2201 so that the variable is still accessible after the loops
2203 ss->data.info.saved_offset = ss->data.info.offset;
2208 /* Initialize a gfc_loopinfo structure. */
2211 gfc_init_loopinfo (gfc_loopinfo * loop)
2215 memset (loop, 0, sizeof (gfc_loopinfo));
2216 gfc_init_block (&loop->pre);
2217 gfc_init_block (&loop->post);
2219 /* Initially scalarize in order and default to no loop reversal. */
2220 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2223 loop->reverse[n] = GFC_CANNOT_REVERSE;
2226 loop->ss = gfc_ss_terminator;
2230 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2234 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2240 /* Return an expression for the data pointer of an array. */
2243 gfc_conv_array_data (tree descriptor)
2247 type = TREE_TYPE (descriptor);
2248 if (GFC_ARRAY_TYPE_P (type))
2250 if (TREE_CODE (type) == POINTER_TYPE)
2254 /* Descriptorless arrays. */
2255 return gfc_build_addr_expr (NULL_TREE, descriptor);
2259 return gfc_conv_descriptor_data_get (descriptor);
2263 /* Return an expression for the base offset of an array. */
2266 gfc_conv_array_offset (tree descriptor)
2270 type = TREE_TYPE (descriptor);
2271 if (GFC_ARRAY_TYPE_P (type))
2272 return GFC_TYPE_ARRAY_OFFSET (type);
2274 return gfc_conv_descriptor_offset_get (descriptor);
2278 /* Get an expression for the array stride. */
2281 gfc_conv_array_stride (tree descriptor, int dim)
2286 type = TREE_TYPE (descriptor);
2288 /* For descriptorless arrays use the array size. */
2289 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2290 if (tmp != NULL_TREE)
2293 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2298 /* Like gfc_conv_array_stride, but for the lower bound. */
2301 gfc_conv_array_lbound (tree descriptor, int dim)
2306 type = TREE_TYPE (descriptor);
2308 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2309 if (tmp != NULL_TREE)
2312 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2317 /* Like gfc_conv_array_stride, but for the upper bound. */
2320 gfc_conv_array_ubound (tree descriptor, int dim)
2325 type = TREE_TYPE (descriptor);
2327 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2328 if (tmp != NULL_TREE)
2331 /* This should only ever happen when passing an assumed shape array
2332 as an actual parameter. The value will never be used. */
2333 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2334 return gfc_index_zero_node;
2336 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2341 /* Generate code to perform an array index bound check. */
2344 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2345 locus * where, bool check_upper)
2348 tree tmp_lo, tmp_up;
2350 const char * name = NULL;
2352 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2355 index = gfc_evaluate_now (index, &se->pre);
2357 /* We find a name for the error message. */
2359 name = se->ss->expr->symtree->name;
2361 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2362 && se->loop->ss->expr->symtree)
2363 name = se->loop->ss->expr->symtree->name;
2365 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2366 && se->loop->ss->loop_chain->expr
2367 && se->loop->ss->loop_chain->expr->symtree)
2368 name = se->loop->ss->loop_chain->expr->symtree->name;
2370 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2372 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2373 && se->loop->ss->expr->value.function.name)
2374 name = se->loop->ss->expr->value.function.name;
2376 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2377 || se->loop->ss->type == GFC_SS_SCALAR)
2378 name = "unnamed constant";
2381 if (TREE_CODE (descriptor) == VAR_DECL)
2382 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2384 /* If upper bound is present, include both bounds in the error message. */
2387 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2388 tmp_up = gfc_conv_array_ubound (descriptor, n);
2391 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2392 "outside of expected range (%%ld:%%ld)", n+1, name);
2394 asprintf (&msg, "Index '%%ld' of dimension %d "
2395 "outside of expected range (%%ld:%%ld)", n+1);
2397 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2399 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2400 fold_convert (long_integer_type_node, index),
2401 fold_convert (long_integer_type_node, tmp_lo),
2402 fold_convert (long_integer_type_node, tmp_up));
2403 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2405 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2406 fold_convert (long_integer_type_node, index),
2407 fold_convert (long_integer_type_node, tmp_lo),
2408 fold_convert (long_integer_type_node, tmp_up));
2413 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2416 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2417 "below lower bound of %%ld", n+1, name);
2419 asprintf (&msg, "Index '%%ld' of dimension %d "
2420 "below lower bound of %%ld", n+1);
2422 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2424 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2425 fold_convert (long_integer_type_node, index),
2426 fold_convert (long_integer_type_node, tmp_lo));
2434 /* Return the offset for an index. Performs bound checking for elemental
2435 dimensions. Single element references are processed separately.
2436 DIM is the array dimension, I is the loop dimension. */
2439 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2440 gfc_array_ref * ar, tree stride)
2446 /* Get the index into the array for this dimension. */
2449 gcc_assert (ar->type != AR_ELEMENT);
2450 switch (ar->dimen_type[dim])
2453 /* Elemental dimension. */
2454 gcc_assert (info->subscript[dim]
2455 && info->subscript[dim]->type == GFC_SS_SCALAR);
2456 /* We've already translated this value outside the loop. */
2457 index = info->subscript[dim]->data.scalar.expr;
2459 index = gfc_trans_array_bound_check (se, info->descriptor,
2460 index, dim, &ar->where,
2461 ar->as->type != AS_ASSUMED_SIZE
2462 || dim < ar->dimen - 1);
2466 gcc_assert (info && se->loop);
2467 gcc_assert (info->subscript[dim]
2468 && info->subscript[dim]->type == GFC_SS_VECTOR);
2469 desc = info->subscript[dim]->data.info.descriptor;
2471 /* Get a zero-based index into the vector. */
2472 index = fold_build2_loc (input_location, MINUS_EXPR,
2473 gfc_array_index_type,
2474 se->loop->loopvar[i], se->loop->from[i]);
2476 /* Multiply the index by the stride. */
2477 index = fold_build2_loc (input_location, MULT_EXPR,
2478 gfc_array_index_type,
2479 index, gfc_conv_array_stride (desc, 0));
2481 /* Read the vector to get an index into info->descriptor. */
2482 data = build_fold_indirect_ref_loc (input_location,
2483 gfc_conv_array_data (desc));
2484 index = gfc_build_array_ref (data, index, NULL);
2485 index = gfc_evaluate_now (index, &se->pre);
2486 index = fold_convert (gfc_array_index_type, index);
2488 /* Do any bounds checking on the final info->descriptor index. */
2489 index = gfc_trans_array_bound_check (se, info->descriptor,
2490 index, dim, &ar->where,
2491 ar->as->type != AS_ASSUMED_SIZE
2492 || dim < ar->dimen - 1);
2496 /* Scalarized dimension. */
2497 gcc_assert (info && se->loop);
2499 /* Multiply the loop variable by the stride and delta. */
2500 index = se->loop->loopvar[i];
2501 if (!integer_onep (info->stride[dim]))
2502 index = fold_build2_loc (input_location, MULT_EXPR,
2503 gfc_array_index_type, index,
2505 if (!integer_zerop (info->delta[dim]))
2506 index = fold_build2_loc (input_location, PLUS_EXPR,
2507 gfc_array_index_type, index,
2517 /* Temporary array or derived type component. */
2518 gcc_assert (se->loop);
2519 index = se->loop->loopvar[se->loop->order[i]];
2520 if (!integer_zerop (info->delta[dim]))
2521 index = fold_build2_loc (input_location, PLUS_EXPR,
2522 gfc_array_index_type, index, info->delta[dim]);
2525 /* Multiply by the stride. */
2526 if (!integer_onep (stride))
2527 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2534 /* Build a scalarized reference to an array. */
2537 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2540 tree decl = NULL_TREE;
2545 info = &se->ss->data.info;
2547 n = se->loop->order[0];
2551 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2553 /* Add the offset for this dimension to the stored offset for all other
2555 if (!integer_zerop (info->offset))
2556 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2557 index, info->offset);
2559 if (se->ss->expr && is_subref_array (se->ss->expr))
2560 decl = se->ss->expr->symtree->n.sym->backend_decl;
2562 tmp = build_fold_indirect_ref_loc (input_location,
2564 se->expr = gfc_build_array_ref (tmp, index, decl);
2568 /* Translate access of temporary array. */
2571 gfc_conv_tmp_array_ref (gfc_se * se)
2573 se->string_length = se->ss->string_length;
2574 gfc_conv_scalarized_array_ref (se, NULL);
2575 gfc_advance_se_ss_chain (se);
2579 /* Build an array reference. se->expr already holds the array descriptor.
2580 This should be either a variable, indirect variable reference or component
2581 reference. For arrays which do not have a descriptor, se->expr will be
2583 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2586 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2599 /* Handle scalarized references separately. */
2600 if (ar->type != AR_ELEMENT)
2602 gfc_conv_scalarized_array_ref (se, ar);
2603 gfc_advance_se_ss_chain (se);
2607 index = gfc_index_zero_node;
2609 /* Calculate the offsets from all the dimensions. */
2610 for (n = 0; n < ar->dimen; n++)
2612 /* Calculate the index for this dimension. */
2613 gfc_init_se (&indexse, se);
2614 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2615 gfc_add_block_to_block (&se->pre, &indexse.pre);
2617 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2619 /* Check array bounds. */
2623 /* Evaluate the indexse.expr only once. */
2624 indexse.expr = save_expr (indexse.expr);
2627 tmp = gfc_conv_array_lbound (se->expr, n);
2628 if (sym->attr.temporary)
2630 gfc_init_se (&tmpse, se);
2631 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2632 gfc_array_index_type);
2633 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2637 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2639 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2640 "below lower bound of %%ld", n+1, sym->name);
2641 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2642 fold_convert (long_integer_type_node,
2644 fold_convert (long_integer_type_node, tmp));
2647 /* Upper bound, but not for the last dimension of assumed-size
2649 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2651 tmp = gfc_conv_array_ubound (se->expr, n);
2652 if (sym->attr.temporary)
2654 gfc_init_se (&tmpse, se);
2655 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2656 gfc_array_index_type);
2657 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2661 cond = fold_build2_loc (input_location, GT_EXPR,
2662 boolean_type_node, indexse.expr, tmp);
2663 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2664 "above upper bound of %%ld", n+1, sym->name);
2665 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2666 fold_convert (long_integer_type_node,
2668 fold_convert (long_integer_type_node, tmp));
2673 /* Multiply the index by the stride. */
2674 stride = gfc_conv_array_stride (se->expr, n);
2675 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2676 indexse.expr, stride);
2678 /* And add it to the total. */
2679 index = fold_build2_loc (input_location, PLUS_EXPR,
2680 gfc_array_index_type, index, tmp);
2683 tmp = gfc_conv_array_offset (se->expr);
2684 if (!integer_zerop (tmp))
2685 index = fold_build2_loc (input_location, PLUS_EXPR,
2686 gfc_array_index_type, index, tmp);
2688 /* Access the calculated element. */
2689 tmp = gfc_conv_array_data (se->expr);
2690 tmp = build_fold_indirect_ref (tmp);
2691 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2695 /* Generate the code to be executed immediately before entering a
2696 scalarization loop. */
2699 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2700 stmtblock_t * pblock)
2709 /* This code will be executed before entering the scalarization loop
2710 for this dimension. */
2711 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2713 if ((ss->useflags & flag) == 0)
2716 if (ss->type != GFC_SS_SECTION
2717 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2718 && ss->type != GFC_SS_COMPONENT)
2721 info = &ss->data.info;
2723 if (dim >= info->dimen)
2726 if (dim == info->dimen - 1)
2728 /* For the outermost loop calculate the offset due to any
2729 elemental dimensions. It will have been initialized with the
2730 base offset of the array. */
2733 for (i = 0; i < info->ref->u.ar.dimen; i++)
2735 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2738 gfc_init_se (&se, NULL);
2740 se.expr = info->descriptor;
2741 stride = gfc_conv_array_stride (info->descriptor, i);
2742 index = gfc_conv_array_index_offset (&se, info, i, -1,
2745 gfc_add_block_to_block (pblock, &se.pre);
2747 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2748 gfc_array_index_type,
2749 info->offset, index);
2750 info->offset = gfc_evaluate_now (info->offset, pblock);
2755 /* For the time being, the innermost loop is unconditionally on
2756 the first dimension of the scalarization loop. */
2757 gcc_assert (i == 0);
2758 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2760 /* Calculate the stride of the innermost loop. Hopefully this will
2761 allow the backend optimizers to do their stuff more effectively.
2763 info->stride0 = gfc_evaluate_now (stride, pblock);
2767 /* Add the offset for the previous loop dimension. */
2772 ar = &info->ref->u.ar;
2773 i = loop->order[dim + 1];
2781 gfc_init_se (&se, NULL);
2783 se.expr = info->descriptor;
2784 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2785 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2787 gfc_add_block_to_block (pblock, &se.pre);
2788 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2789 gfc_array_index_type, info->offset,
2791 info->offset = gfc_evaluate_now (info->offset, pblock);
2794 /* Remember this offset for the second loop. */
2795 if (dim == loop->temp_dim - 1)
2796 info->saved_offset = info->offset;
2801 /* Start a scalarized expression. Creates a scope and declares loop
2805 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2811 gcc_assert (!loop->array_parameter);
2813 for (dim = loop->dimen - 1; dim >= 0; dim--)
2815 n = loop->order[dim];
2817 gfc_start_block (&loop->code[n]);
2819 /* Create the loop variable. */
2820 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2822 if (dim < loop->temp_dim)
2826 /* Calculate values that will be constant within this loop. */
2827 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2829 gfc_start_block (pbody);
2833 /* Generates the actual loop code for a scalarization loop. */
2836 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2837 stmtblock_t * pbody)
2848 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2849 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2850 && n == loop->dimen - 1)
2852 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2853 init = make_tree_vec (1);
2854 cond = make_tree_vec (1);
2855 incr = make_tree_vec (1);
2857 /* Cycle statement is implemented with a goto. Exit statement must not
2858 be present for this loop. */
2859 exit_label = gfc_build_label_decl (NULL_TREE);
2860 TREE_USED (exit_label) = 1;
2862 /* Label for cycle statements (if needed). */
2863 tmp = build1_v (LABEL_EXPR, exit_label);
2864 gfc_add_expr_to_block (pbody, tmp);
2866 stmt = make_node (OMP_FOR);
2868 TREE_TYPE (stmt) = void_type_node;
2869 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2871 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2872 OMP_CLAUSE_SCHEDULE);
2873 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2874 = OMP_CLAUSE_SCHEDULE_STATIC;
2875 if (ompws_flags & OMPWS_NOWAIT)
2876 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2877 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2879 /* Initialize the loopvar. */
2880 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2882 OMP_FOR_INIT (stmt) = init;
2883 /* The exit condition. */
2884 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2886 loop->loopvar[n], loop->to[n]);
2887 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2888 OMP_FOR_COND (stmt) = cond;
2889 /* Increment the loopvar. */
2890 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2891 loop->loopvar[n], gfc_index_one_node);
2892 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2893 void_type_node, loop->loopvar[n], tmp);
2894 OMP_FOR_INCR (stmt) = incr;
2896 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2897 gfc_add_expr_to_block (&loop->code[n], stmt);
2901 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2902 && (loop->temp_ss == NULL);
2904 loopbody = gfc_finish_block (pbody);
2908 tmp = loop->from[n];
2909 loop->from[n] = loop->to[n];
2913 /* Initialize the loopvar. */
2914 if (loop->loopvar[n] != loop->from[n])
2915 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2917 exit_label = gfc_build_label_decl (NULL_TREE);
2919 /* Generate the loop body. */
2920 gfc_init_block (&block);
2922 /* The exit condition. */
2923 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2924 boolean_type_node, loop->loopvar[n], loop->to[n]);
2925 tmp = build1_v (GOTO_EXPR, exit_label);
2926 TREE_USED (exit_label) = 1;
2927 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2928 gfc_add_expr_to_block (&block, tmp);
2930 /* The main body. */
2931 gfc_add_expr_to_block (&block, loopbody);
2933 /* Increment the loopvar. */
2934 tmp = fold_build2_loc (input_location,
2935 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2936 gfc_array_index_type, loop->loopvar[n],
2937 gfc_index_one_node);
2939 gfc_add_modify (&block, loop->loopvar[n], tmp);
2941 /* Build the loop. */
2942 tmp = gfc_finish_block (&block);
2943 tmp = build1_v (LOOP_EXPR, tmp);
2944 gfc_add_expr_to_block (&loop->code[n], tmp);
2946 /* Add the exit label. */
2947 tmp = build1_v (LABEL_EXPR, exit_label);
2948 gfc_add_expr_to_block (&loop->code[n], tmp);
2954 /* Finishes and generates the loops for a scalarized expression. */
2957 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2962 stmtblock_t *pblock;
2966 /* Generate the loops. */
2967 for (dim = 0; dim < loop->dimen; dim++)
2969 n = loop->order[dim];
2970 gfc_trans_scalarized_loop_end (loop, n, pblock);
2971 loop->loopvar[n] = NULL_TREE;
2972 pblock = &loop->code[n];
2975 tmp = gfc_finish_block (pblock);
2976 gfc_add_expr_to_block (&loop->pre, tmp);
2978 /* Clear all the used flags. */
2979 for (ss = loop->ss; ss; ss = ss->loop_chain)
2984 /* Finish the main body of a scalarized expression, and start the secondary
2988 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2992 stmtblock_t *pblock;
2996 /* We finish as many loops as are used by the temporary. */
2997 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2999 n = loop->order[dim];
3000 gfc_trans_scalarized_loop_end (loop, n, pblock);
3001 loop->loopvar[n] = NULL_TREE;
3002 pblock = &loop->code[n];
3005 /* We don't want to finish the outermost loop entirely. */
3006 n = loop->order[loop->temp_dim - 1];
3007 gfc_trans_scalarized_loop_end (loop, n, pblock);
3009 /* Restore the initial offsets. */
3010 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3012 if ((ss->useflags & 2) == 0)
3015 if (ss->type != GFC_SS_SECTION
3016 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3017 && ss->type != GFC_SS_COMPONENT)
3020 ss->data.info.offset = ss->data.info.saved_offset;
3023 /* Restart all the inner loops we just finished. */
3024 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3026 n = loop->order[dim];
3028 gfc_start_block (&loop->code[n]);
3030 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3032 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3035 /* Start a block for the secondary copying code. */
3036 gfc_start_block (body);
3040 /* Calculate the lower bound of an array section. */
3043 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3052 gcc_assert (ss->type == GFC_SS_SECTION);
3054 info = &ss->data.info;
3056 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3058 /* We use a zero-based index to access the vector. */
3059 info->start[dim] = gfc_index_zero_node;
3060 info->stride[dim] = gfc_index_one_node;
3061 info->end[dim] = NULL;
3065 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3066 desc = info->descriptor;
3067 start = info->ref->u.ar.start[dim];
3068 end = info->ref->u.ar.end[dim];
3069 stride = info->ref->u.ar.stride[dim];
3071 /* Calculate the start of the range. For vector subscripts this will
3072 be the range of the vector. */
3075 /* Specified section start. */
3076 gfc_init_se (&se, NULL);
3077 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3078 gfc_add_block_to_block (&loop->pre, &se.pre);
3079 info->start[dim] = se.expr;
3083 /* No lower bound specified so use the bound of the array. */
3084 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3086 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3088 /* Similarly calculate the end. Although this is not used in the
3089 scalarizer, it is needed when checking bounds and where the end
3090 is an expression with side-effects. */
3093 /* Specified section start. */
3094 gfc_init_se (&se, NULL);
3095 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3096 gfc_add_block_to_block (&loop->pre, &se.pre);
3097 info->end[dim] = se.expr;
3101 /* No upper bound specified so use the bound of the array. */
3102 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3104 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3106 /* Calculate the stride. */
3108 info->stride[dim] = gfc_index_one_node;
3111 gfc_init_se (&se, NULL);
3112 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3113 gfc_add_block_to_block (&loop->pre, &se.pre);
3114 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3119 /* Calculates the range start and stride for a SS chain. Also gets the
3120 descriptor and data pointer. The range of vector subscripts is the size
3121 of the vector. Array bounds are also checked. */
3124 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3132 /* Determine the rank of the loop. */
3134 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3138 case GFC_SS_SECTION:
3139 case GFC_SS_CONSTRUCTOR:
3140 case GFC_SS_FUNCTION:
3141 case GFC_SS_COMPONENT:
3142 loop->dimen = ss->data.info.dimen;
3145 /* As usual, lbound and ubound are exceptions!. */
3146 case GFC_SS_INTRINSIC:
3147 switch (ss->expr->value.function.isym->id)
3149 case GFC_ISYM_LBOUND:
3150 case GFC_ISYM_UBOUND:
3151 loop->dimen = ss->data.info.dimen;
3162 /* We should have determined the rank of the expression by now. If
3163 not, that's bad news. */
3164 gcc_assert (loop->dimen != 0);
3166 /* Loop over all the SS in the chain. */
3167 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3169 if (ss->expr && ss->expr->shape && !ss->shape)
3170 ss->shape = ss->expr->shape;
3174 case GFC_SS_SECTION:
3175 /* Get the descriptor for the array. */
3176 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3178 for (n = 0; n < ss->data.info.dimen; n++)
3179 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3182 case GFC_SS_INTRINSIC:
3183 switch (ss->expr->value.function.isym->id)
3185 /* Fall through to supply start and stride. */
3186 case GFC_ISYM_LBOUND:
3187 case GFC_ISYM_UBOUND:
3193 case GFC_SS_CONSTRUCTOR:
3194 case GFC_SS_FUNCTION:
3195 for (n = 0; n < ss->data.info.dimen; n++)
3197 ss->data.info.start[n] = gfc_index_zero_node;
3198 ss->data.info.end[n] = gfc_index_zero_node;
3199 ss->data.info.stride[n] = gfc_index_one_node;
3208 /* The rest is just runtime bound checking. */
3209 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3212 tree lbound, ubound;
3214 tree size[GFC_MAX_DIMENSIONS];
3215 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3220 gfc_start_block (&block);
3222 for (n = 0; n < loop->dimen; n++)
3223 size[n] = NULL_TREE;
3225 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3229 if (ss->type != GFC_SS_SECTION)
3232 /* Catch allocatable lhs in f2003. */
3233 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3236 gfc_start_block (&inner);
3238 /* TODO: range checking for mapped dimensions. */
3239 info = &ss->data.info;
3241 /* This code only checks ranges. Elemental and vector
3242 dimensions are checked later. */
3243 for (n = 0; n < loop->dimen; n++)
3248 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3251 if (dim == info->ref->u.ar.dimen - 1
3252 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3253 check_upper = false;
3257 /* Zero stride is not allowed. */
3258 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3259 info->stride[dim], gfc_index_zero_node);
3260 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3261 "of array '%s'", dim + 1, ss->expr->symtree->name);
3262 gfc_trans_runtime_check (true, false, tmp, &inner,
3263 &ss->expr->where, msg);
3266 desc = ss->data.info.descriptor;
3268 /* This is the run-time equivalent of resolve.c's
3269 check_dimension(). The logical is more readable there
3270 than it is here, with all the trees. */
3271 lbound = gfc_conv_array_lbound (desc, dim);
3272 end = info->end[dim];
3274 ubound = gfc_conv_array_ubound (desc, dim);
3278 /* non_zerosized is true when the selected range is not
3280 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3281 boolean_type_node, info->stride[dim],
3282 gfc_index_zero_node);
3283 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3284 info->start[dim], end);
3285 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3286 boolean_type_node, stride_pos, tmp);
3288 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3290 info->stride[dim], gfc_index_zero_node);
3291 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3292 info->start[dim], end);
3293 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3296 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3298 stride_pos, stride_neg);
3300 /* Check the start of the range against the lower and upper
3301 bounds of the array, if the range is not empty.
3302 If upper bound is present, include both bounds in the
3306 tmp = fold_build2_loc (input_location, LT_EXPR,
3308 info->start[dim], lbound);
3309 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3311 non_zerosized, tmp);
3312 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3314 info->start[dim], ubound);
3315 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3317 non_zerosized, tmp2);
3318 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3319 "outside of expected range (%%ld:%%ld)",
3320 dim + 1, ss->expr->symtree->name);
3321 gfc_trans_runtime_check (true, false, tmp, &inner,
3322 &ss->expr->where, msg,
3323 fold_convert (long_integer_type_node, info->start[dim]),
3324 fold_convert (long_integer_type_node, lbound),
3325 fold_convert (long_integer_type_node, ubound));
3326 gfc_trans_runtime_check (true, false, tmp2, &inner,
3327 &ss->expr->where, msg,
3328 fold_convert (long_integer_type_node, info->start[dim]),
3329 fold_convert (long_integer_type_node, lbound),
3330 fold_convert (long_integer_type_node, ubound));
3335 tmp = fold_build2_loc (input_location, LT_EXPR,
3337 info->start[dim], lbound);
3338 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3339 boolean_type_node, non_zerosized, tmp);
3340 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3341 "below lower bound of %%ld",
3342 dim + 1, ss->expr->symtree->name);
3343 gfc_trans_runtime_check (true, false, tmp, &inner,
3344 &ss->expr->where, msg,
3345 fold_convert (long_integer_type_node, info->start[dim]),
3346 fold_convert (long_integer_type_node, lbound));
3350 /* Compute the last element of the range, which is not
3351 necessarily "end" (think 0:5:3, which doesn't contain 5)
3352 and check it against both lower and upper bounds. */
3354 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3355 gfc_array_index_type, end,
3357 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3358 gfc_array_index_type, tmp,
3360 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3361 gfc_array_index_type, end, tmp);
3362 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3363 boolean_type_node, tmp, lbound);
3364 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3365 boolean_type_node, non_zerosized, tmp2);
3368 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3369 boolean_type_node, tmp, ubound);
3370 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3371 boolean_type_node, non_zerosized, tmp3);
3372 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3373 "outside of expected range (%%ld:%%ld)",
3374 dim + 1, ss->expr->symtree->name);
3375 gfc_trans_runtime_check (true, false, tmp2, &inner,
3376 &ss->expr->where, msg,
3377 fold_convert (long_integer_type_node, tmp),
3378 fold_convert (long_integer_type_node, ubound),
3379 fold_convert (long_integer_type_node, lbound));
3380 gfc_trans_runtime_check (true, false, tmp3, &inner,
3381 &ss->expr->where, msg,
3382 fold_convert (long_integer_type_node, tmp),
3383 fold_convert (long_integer_type_node, ubound),
3384 fold_convert (long_integer_type_node, lbound));
3389 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3390 "below lower bound of %%ld",
3391 dim + 1, ss->expr->symtree->name);
3392 gfc_trans_runtime_check (true, false, tmp2, &inner,
3393 &ss->expr->where, msg,
3394 fold_convert (long_integer_type_node, tmp),
3395 fold_convert (long_integer_type_node, lbound));
3399 /* Check the section sizes match. */
3400 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3401 gfc_array_index_type, end,
3403 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3404 gfc_array_index_type, tmp,
3406 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3407 gfc_array_index_type,
3408 gfc_index_one_node, tmp);
3409 tmp = fold_build2_loc (input_location, MAX_EXPR,
3410 gfc_array_index_type, tmp,
3411 build_int_cst (gfc_array_index_type, 0));
3412 /* We remember the size of the first section, and check all the
3413 others against this. */
3416 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3417 boolean_type_node, tmp, size[n]);
3418 asprintf (&msg, "Array bound mismatch for dimension %d "
3419 "of array '%s' (%%ld/%%ld)",
3420 dim + 1, ss->expr->symtree->name);
3422 gfc_trans_runtime_check (true, false, tmp3, &inner,
3423 &ss->expr->where, msg,
3424 fold_convert (long_integer_type_node, tmp),
3425 fold_convert (long_integer_type_node, size[n]));
3430 size[n] = gfc_evaluate_now (tmp, &inner);
3433 tmp = gfc_finish_block (&inner);
3435 /* For optional arguments, only check bounds if the argument is
3437 if (ss->expr->symtree->n.sym->attr.optional
3438 || ss->expr->symtree->n.sym->attr.not_always_present)
3439 tmp = build3_v (COND_EXPR,
3440 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3441 tmp, build_empty_stmt (input_location));
3443 gfc_add_expr_to_block (&block, tmp);
3447 tmp = gfc_finish_block (&block);
3448 gfc_add_expr_to_block (&loop->pre, tmp);
3453 /* Return true if the two SS could be aliased, i.e. both point to the same data
3455 /* TODO: resolve aliases based on frontend expressions. */
3458 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3465 lsym = lss->expr->symtree->n.sym;
3466 rsym = rss->expr->symtree->n.sym;
3467 if (gfc_symbols_could_alias (lsym, rsym))
3470 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3471 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3474 /* For derived types we must check all the component types. We can ignore
3475 array references as these will have the same base type as the previous
3477 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3479 if (lref->type != REF_COMPONENT)
3482 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3485 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3488 if (rref->type != REF_COMPONENT)
3491 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3496 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3498 if (rref->type != REF_COMPONENT)
3501 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3509 /* Resolve array data dependencies. Creates a temporary if required. */
3510 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3514 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3523 loop->temp_ss = NULL;
3525 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3527 if (ss->type != GFC_SS_SECTION)
3530 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3532 if (gfc_could_be_alias (dest, ss)
3533 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3541 lref = dest->expr->ref;
3542 rref = ss->expr->ref;
3544 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3549 for (i = 0; i < dest->data.info.dimen; i++)
3550 for (j = 0; j < ss->data.info.dimen; j++)
3552 && dest->data.info.dim[i] == ss->data.info.dim[j])
3554 /* If we don't access array elements in the same order,
3555 there is a dependency. */
3560 /* TODO : loop shifting. */
3563 /* Mark the dimensions for LOOP SHIFTING */
3564 for (n = 0; n < loop->dimen; n++)
3566 int dim = dest->data.info.dim[n];
3568 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3570 else if (! gfc_is_same_range (&lref->u.ar,
3571 &rref->u.ar, dim, 0))
3575 /* Put all the dimensions with dependencies in the
3578 for (n = 0; n < loop->dimen; n++)
3580 gcc_assert (loop->order[n] == n);
3582 loop->order[dim++] = n;
3584 for (n = 0; n < loop->dimen; n++)
3587 loop->order[dim++] = n;
3590 gcc_assert (dim == loop->dimen);
3601 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3602 if (GFC_ARRAY_TYPE_P (base_type)
3603 || GFC_DESCRIPTOR_TYPE_P (base_type))
3604 base_type = gfc_get_element_type (base_type);
3605 loop->temp_ss = gfc_get_ss ();
3606 loop->temp_ss->type = GFC_SS_TEMP;
3607 loop->temp_ss->data.temp.type = base_type;
3608 loop->temp_ss->string_length = dest->string_length;
3609 loop->temp_ss->data.temp.dimen = loop->dimen;
3610 loop->temp_ss->next = gfc_ss_terminator;
3611 gfc_add_ss_to_loop (loop, loop->temp_ss);
3614 loop->temp_ss = NULL;
3618 /* Initialize the scalarization loop. Creates the loop variables. Determines
3619 the range of the loop variables. Creates a temporary if required.
3620 Calculates how to transform from loop variables to array indices for each
3621 expression. Also generates code for scalar expressions which have been
3622 moved outside the loop. */
3625 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3627 int n, dim, spec_dim;
3629 gfc_ss_info *specinfo;
3632 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3633 bool dynamic[GFC_MAX_DIMENSIONS];
3638 for (n = 0; n < loop->dimen; n++)
3642 /* We use one SS term, and use that to determine the bounds of the
3643 loop for this dimension. We try to pick the simplest term. */
3644 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3646 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3649 info = &ss->data.info;
3652 if (loopspec[n] != NULL)
3654 specinfo = &loopspec[n]->data.info;
3655 spec_dim = specinfo->dim[n];
3659 /* Silence unitialized warnings. */
3666 gcc_assert (ss->shape[dim]);
3667 /* The frontend has worked out the size for us. */
3669 || !loopspec[n]->shape
3670 || !integer_zerop (specinfo->start[spec_dim]))
3671 /* Prefer zero-based descriptors if possible. */
3676 if (ss->type == GFC_SS_CONSTRUCTOR)
3678 gfc_constructor_base base;
3679 /* An unknown size constructor will always be rank one.
3680 Higher rank constructors will either have known shape,
3681 or still be wrapped in a call to reshape. */
3682 gcc_assert (loop->dimen == 1);
3684 /* Always prefer to use the constructor bounds if the size
3685 can be determined at compile time. Prefer not to otherwise,
3686 since the general case involves realloc, and it's better to
3687 avoid that overhead if possible. */
3688 base = ss->expr->value.constructor;
3689 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3690 if (!dynamic[n] || !loopspec[n])
3695 /* TODO: Pick the best bound if we have a choice between a
3696 function and something else. */
3697 if (ss->type == GFC_SS_FUNCTION)
3703 /* Avoid using an allocatable lhs in an assignment, since
3704 there might be a reallocation coming. */
3705 if (loopspec[n] && ss->is_alloc_lhs)
3708 if (ss->type != GFC_SS_SECTION)
3713 /* Criteria for choosing a loop specifier (most important first):
3714 doesn't need realloc
3720 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3722 else if (integer_onep (info->stride[dim])
3723 && !integer_onep (specinfo->stride[spec_dim]))
3725 else if (INTEGER_CST_P (info->stride[dim])
3726 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3728 else if (INTEGER_CST_P (info->start[dim])
3729 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3731 /* We don't work out the upper bound.
3732 else if (INTEGER_CST_P (info->finish[n])
3733 && ! INTEGER_CST_P (specinfo->finish[n]))
3734 loopspec[n] = ss; */
3737 /* We should have found the scalarization loop specifier. If not,
3739 gcc_assert (loopspec[n]);
3741 info = &loopspec[n]->data.info;
3744 /* Set the extents of this range. */
3745 cshape = loopspec[n]->shape;
3746 if (cshape && INTEGER_CST_P (info->start[dim])
3747 && INTEGER_CST_P (info->stride[dim]))
3749 loop->from[n] = info->start[dim];
3750 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3751 mpz_sub_ui (i, i, 1);
3752 /* To = from + (size - 1) * stride. */
3753 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3754 if (!integer_onep (info->stride[dim]))
3755 tmp = fold_build2_loc (input_location, MULT_EXPR,
3756 gfc_array_index_type, tmp,
3758 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3759 gfc_array_index_type,
3760 loop->from[n], tmp);
3764 loop->from[n] = info->start[dim];
3765 switch (loopspec[n]->type)
3767 case GFC_SS_CONSTRUCTOR:
3768 /* The upper bound is calculated when we expand the
3770 gcc_assert (loop->to[n] == NULL_TREE);
3773 case GFC_SS_SECTION:
3774 /* Use the end expression if it exists and is not constant,
3775 so that it is only evaluated once. */
3776 loop->to[n] = info->end[dim];
3779 case GFC_SS_FUNCTION:
3780 /* The loop bound will be set when we generate the call. */
3781 gcc_assert (loop->to[n] == NULL_TREE);
3789 /* Transform everything so we have a simple incrementing variable. */
3790 if (integer_onep (info->stride[dim]))
3791 info->delta[dim] = gfc_index_zero_node;
3794 /* Set the delta for this section. */
3795 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3796 /* Number of iterations is (end - start + step) / step.
3797 with start = 0, this simplifies to
3799 for (i = 0; i<=last; i++){...}; */
3800 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3801 gfc_array_index_type, loop->to[n],
3803 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3804 gfc_array_index_type, tmp, info->stride[dim]);
3805 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3806 tmp, build_int_cst (gfc_array_index_type, -1));
3807 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3808 /* Make the loop variable start at 0. */
3809 loop->from[n] = gfc_index_zero_node;
3813 /* Add all the scalar code that can be taken out of the loops.
3814 This may include calculating the loop bounds, so do it before
3815 allocating the temporary. */
3816 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3818 /* If we want a temporary then create it. */
3819 if (loop->temp_ss != NULL)
3821 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3823 /* Make absolutely sure that this is a complete type. */
3824 if (loop->temp_ss->string_length)
3825 loop->temp_ss->data.temp.type
3826 = gfc_get_character_type_len_for_eltype
3827 (TREE_TYPE (loop->temp_ss->data.temp.type),
3828 loop->temp_ss->string_length);
3830 tmp = loop->temp_ss->data.temp.type;
3831 n = loop->temp_ss->data.temp.dimen;
3832 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3833 loop->temp_ss->type = GFC_SS_SECTION;
3834 loop->temp_ss->data.info.dimen = n;
3836 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3837 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3838 loop->temp_ss->data.info.dim[n] = n;
3840 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3841 &loop->temp_ss->data.info, tmp, NULL_TREE,
3842 false, true, false, where);
3845 for (n = 0; n < loop->temp_dim; n++)
3846 loopspec[loop->order[n]] = NULL;
3850 /* For array parameters we don't have loop variables, so don't calculate the
3852 if (loop->array_parameter)
3855 /* Calculate the translation from loop variables to array indices. */
3856 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3858 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3859 && ss->type != GFC_SS_CONSTRUCTOR)
3863 info = &ss->data.info;
3865 for (n = 0; n < info->dimen; n++)
3867 /* If we are specifying the range the delta is already set. */
3868 if (loopspec[n] != ss)
3870 dim = ss->data.info.dim[n];
3872 /* Calculate the offset relative to the loop variable.
3873 First multiply by the stride. */
3874 tmp = loop->from[n];
3875 if (!integer_onep (info->stride[dim]))
3876 tmp = fold_build2_loc (input_location, MULT_EXPR,
3877 gfc_array_index_type,
3878 tmp, info->stride[dim]);
3880 /* Then subtract this from our starting value. */
3881 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3882 gfc_array_index_type,
3883 info->start[dim], tmp);
3885 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
3892 /* Calculate the size of a given array dimension from the bounds. This
3893 is simply (ubound - lbound + 1) if this expression is positive
3894 or 0 if it is negative (pick either one if it is zero). Optionally
3895 (if or_expr is present) OR the (expression != 0) condition to it. */
3898 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
3903 /* Calculate (ubound - lbound + 1). */
3904 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3906 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
3907 gfc_index_one_node);
3909 /* Check whether the size for this dimension is negative. */
3910 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
3911 gfc_index_zero_node);
3912 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
3913 gfc_index_zero_node, res);
3915 /* Build OR expression. */
3917 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3918 boolean_type_node, *or_expr, cond);
3924 /* For an array descriptor, get the total number of elements. This is just
3925 the product of the extents along all dimensions. */
3928 gfc_conv_descriptor_size (tree desc, int rank)
3933 res = gfc_index_one_node;
3935 for (dim = 0; dim < rank; ++dim)
3941 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
3942 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
3944 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
3945 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3953 /* Helper function for marking a boolean expression tree as unlikely. */
3956 gfc_unlikely (tree cond)
3960 cond = fold_convert (long_integer_type_node, cond);
3961 tmp = build_zero_cst (long_integer_type_node);
3962 cond = build_call_expr_loc (input_location,
3963 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
3964 cond = fold_convert (boolean_type_node, cond);
3968 /* Fills in an array descriptor, and returns the size of the array.
3969 The size will be a simple_val, ie a variable or a constant. Also
3970 calculates the offset of the base. The pointer argument overflow,
3971 which should be of integer type, will increase in value if overflow
3972 occurs during the size calculation. Returns the size of the array.
3976 for (n = 0; n < rank; n++)
3978 a.lbound[n] = specified_lower_bound;
3979 offset = offset + a.lbond[n] * stride;
3981 a.ubound[n] = specified_upper_bound;
3982 a.stride[n] = stride;
3983 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3984 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
3985 stride = stride * size;
3987 element_size = sizeof (array element);
3988 stride = (size_t) stride;
3989 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
3990 stride = stride * element_size;
3996 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3997 gfc_expr ** lower, gfc_expr ** upper,
3998 stmtblock_t * pblock, tree * overflow)
4010 stmtblock_t thenblock;
4011 stmtblock_t elseblock;
4016 type = TREE_TYPE (descriptor);
4018 stride = gfc_index_one_node;
4019 offset = gfc_index_zero_node;
4021 /* Set the dtype. */
4022 tmp = gfc_conv_descriptor_dtype (descriptor);
4023 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4025 or_expr = boolean_false_node;
4027 for (n = 0; n < rank; n++)
4032 /* We have 3 possibilities for determining the size of the array:
4033 lower == NULL => lbound = 1, ubound = upper[n]
4034 upper[n] = NULL => lbound = 1, ubound = lower[n]
4035 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4038 /* Set lower bound. */
4039 gfc_init_se (&se, NULL);
4041 se.expr = gfc_index_one_node;
4044 gcc_assert (lower[n]);
4047 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4048 gfc_add_block_to_block (pblock, &se.pre);
4052 se.expr = gfc_index_one_node;
4056 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4058 conv_lbound = se.expr;
4060 /* Work out the offset for this component. */
4061 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4063 offset = fold_build2_loc (input_location, MINUS_EXPR,
4064 gfc_array_index_type, offset, tmp);
4066 /* Set upper bound. */
4067 gfc_init_se (&se, NULL);
4068 gcc_assert (ubound);
4069 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4070 gfc_add_block_to_block (pblock, &se.pre);
4072 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4073 gfc_rank_cst[n], se.expr);
4074 conv_ubound = se.expr;
4076 /* Store the stride. */
4077 gfc_conv_descriptor_stride_set (pblock, descriptor,
4078 gfc_rank_cst[n], stride);
4080 /* Calculate size and check whether extent is negative. */
4081 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4082 size = gfc_evaluate_now (size, pblock);
4084 /* Check whether multiplying the stride by the number of
4085 elements in this dimension would overflow. We must also check
4086 whether the current dimension has zero size in order to avoid
4089 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4090 gfc_array_index_type,
4091 fold_convert (gfc_array_index_type,
4092 TYPE_MAX_VALUE (gfc_array_index_type)),
4094 tmp = fold_build3_loc
4095 (input_location, COND_EXPR, integer_type_node,
4096 gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4097 boolean_type_node, tmp, stride)),
4098 integer_one_node, integer_zero_node);
4099 tmp = fold_build3_loc
4100 (input_location, COND_EXPR, integer_type_node,
4101 gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4102 boolean_type_node, size,
4103 build_zero_cst (gfc_array_index_type))),
4104 integer_zero_node, tmp);
4105 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4107 *overflow = gfc_evaluate_now (tmp, pblock);
4109 /* Multiply the stride by the number of elements in this dimension. */
4110 stride = fold_build2_loc (input_location, MULT_EXPR,
4111 gfc_array_index_type, stride, size);
4112 stride = gfc_evaluate_now (stride, pblock);
4115 for (n = rank; n < rank + corank; n++)
4119 /* Set lower bound. */
4120 gfc_init_se (&se, NULL);
4121 if (lower == NULL || lower[n] == NULL)
4123 gcc_assert (n == rank + corank - 1);
4124 se.expr = gfc_index_one_node;
4128 if (ubound || n == rank + corank - 1)
4130 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4131 gfc_add_block_to_block (pblock, &se.pre);
4135 se.expr = gfc_index_one_node;
4139 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4142 if (n < rank + corank - 1)
4144 gfc_init_se (&se, NULL);
4145 gcc_assert (ubound);
4146 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4147 gfc_add_block_to_block (pblock, &se.pre);
4148 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4149 gfc_rank_cst[n], se.expr);
4153 /* The stride is the number of elements in the array, so multiply by the
4154 size of an element to get the total size. */
4155 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4156 /* Convert to size_t. */
4157 element_size = fold_convert (sizetype, tmp);
4158 stride = fold_convert (sizetype, stride);
4160 /* First check for overflow. Since an array of type character can
4161 have zero element_size, we must check for that before
4163 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4165 TYPE_MAX_VALUE (sizetype), element_size);
4166 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
4167 gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4168 boolean_type_node, tmp,
4170 integer_one_node, integer_zero_node);
4171 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
4172 gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4176 integer_zero_node, tmp);
4177 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4179 *overflow = gfc_evaluate_now (tmp, pblock);
4181 size = fold_build2_loc (input_location, MULT_EXPR, sizetype,
4182 stride, element_size);
4184 if (poffset != NULL)
4186 offset = gfc_evaluate_now (offset, pblock);
4190 if (integer_zerop (or_expr))
4192 if (integer_onep (or_expr))
4193 return gfc_index_zero_node;
4195 var = gfc_create_var (TREE_TYPE (size), "size");
4196 gfc_start_block (&thenblock);
4197 gfc_add_modify (&thenblock, var, size_zero_node);
4198 thencase = gfc_finish_block (&thenblock);
4200 gfc_start_block (&elseblock);
4201 gfc_add_modify (&elseblock, var, size);
4202 elsecase = gfc_finish_block (&elseblock);
4204 tmp = gfc_evaluate_now (or_expr, pblock);
4205 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4206 gfc_add_expr_to_block (pblock, tmp);
4212 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4213 the work for an ALLOCATE statement. */
4217 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4225 tree overflow; /* Boolean storing whether size calculation overflows. */
4228 stmtblock_t elseblock;
4231 gfc_ref *ref, *prev_ref = NULL;
4232 bool allocatable_array, coarray;
4236 /* Find the last reference in the chain. */
4237 while (ref && ref->next != NULL)
4239 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4240 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4245 if (ref == NULL || ref->type != REF_ARRAY)
4250 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4251 coarray = expr->symtree->n.sym->attr.codimension;
4255 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4256 coarray = prev_ref->u.c.component->attr.codimension;
4259 /* Return if this is a scalar coarray. */
4260 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4261 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4263 gcc_assert (coarray);
4267 /* Figure out the size of the array. */
4268 switch (ref->u.ar.type)
4274 upper = ref->u.ar.start;
4280 lower = ref->u.ar.start;
4281 upper = ref->u.ar.end;
4285 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4287 lower = ref->u.ar.as->lower;
4288 upper = ref->u.ar.as->upper;
4296 overflow = integer_zero_node;
4297 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4298 ref->u.ar.as->corank, &offset, lower, upper,
4299 &se->pre, &overflow);
4301 var_overflow = gfc_create_var (integer_type_node, "overflow");
4302 gfc_add_modify (&se->pre, var_overflow, overflow);
4304 /* Generate the block of code handling overflow. */
4305 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
4306 ("Integer overflow when calculating the amount of "
4307 "memory to allocate"));
4308 error = build_call_expr_loc (input_location,
4309 gfor_fndecl_runtime_error, 1, msg);
4311 if (pstat != NULL_TREE && !integer_zerop (pstat))
4313 /* Set the status variable if it's present. */
4314 stmtblock_t set_status_block;
4315 tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
4317 gfc_start_block (&set_status_block);
4318 gfc_add_modify (&set_status_block,
4319 fold_build1_loc (input_location, INDIRECT_REF,
4320 status_type, pstat),
4321 build_int_cst (status_type, LIBERROR_ALLOCATION));
4323 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4324 pstat, build_int_cst (TREE_TYPE (pstat), 0));
4325 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
4326 error, gfc_finish_block (&set_status_block));
4329 gfc_start_block (&elseblock);
4331 /* Allocate memory to store the data. */
4332 pointer = gfc_conv_descriptor_data_get (se->expr);
4333 STRIP_NOPS (pointer);
4335 /* The allocate_array variants take the old pointer as first argument. */
4336 if (allocatable_array)
4337 tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr);
4339 tmp = gfc_allocate_with_status (&elseblock, size, pstat);
4340 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4343 gfc_add_expr_to_block (&elseblock, tmp);
4345 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4346 var_overflow, integer_zero_node));
4347 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4348 error, gfc_finish_block (&elseblock));
4350 gfc_add_expr_to_block (&se->pre, tmp);
4352 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4354 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4355 && expr->ts.u.derived->attr.alloc_comp)
4357 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4358 ref->u.ar.as->rank);
4359 gfc_add_expr_to_block (&se->pre, tmp);
4366 /* Deallocate an array variable. Also used when an allocated variable goes
4371 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4377 gfc_start_block (&block);
4378 /* Get a pointer to the data. */
4379 var = gfc_conv_descriptor_data_get (descriptor);
4382 /* Parameter is the address of the data component. */
4383 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4384 gfc_add_expr_to_block (&block, tmp);
4386 /* Zero the data pointer. */
4387 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4388 var, build_int_cst (TREE_TYPE (var), 0));
4389 gfc_add_expr_to_block (&block, tmp);
4391 return gfc_finish_block (&block);
4395 /* Create an array constructor from an initialization expression.
4396 We assume the frontend already did any expansions and conversions. */
4399 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4405 unsigned HOST_WIDE_INT lo;
4407 VEC(constructor_elt,gc) *v = NULL;
4409 switch (expr->expr_type)
4412 case EXPR_STRUCTURE:
4413 /* A single scalar or derived type value. Create an array with all
4414 elements equal to that value. */
4415 gfc_init_se (&se, NULL);
4417 if (expr->expr_type == EXPR_CONSTANT)
4418 gfc_conv_constant (&se, expr);
4420 gfc_conv_structure (&se, expr, 1);
4422 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4423 gcc_assert (tmp && INTEGER_CST_P (tmp));
4424 hi = TREE_INT_CST_HIGH (tmp);
4425 lo = TREE_INT_CST_LOW (tmp);
4429 /* This will probably eat buckets of memory for large arrays. */
4430 while (hi != 0 || lo != 0)
4432 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4440 /* Create a vector of all the elements. */
4441 for (c = gfc_constructor_first (expr->value.constructor);
4442 c; c = gfc_constructor_next (c))
4446 /* Problems occur when we get something like
4447 integer :: a(lots) = (/(i, i=1, lots)/) */
4448 gfc_fatal_error ("The number of elements in the array constructor "
4449 "at %L requires an increase of the allowed %d "
4450 "upper limit. See -fmax-array-constructor "
4451 "option", &expr->where,
4452 gfc_option.flag_max_array_constructor);
4455 if (mpz_cmp_si (c->offset, 0) != 0)
4456 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4460 gfc_init_se (&se, NULL);
4461 switch (c->expr->expr_type)
4464 gfc_conv_constant (&se, c->expr);
4465 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4468 case EXPR_STRUCTURE:
4469 gfc_conv_structure (&se, c->expr, 1);
4470 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4475 /* Catch those occasional beasts that do not simplify
4476 for one reason or another, assuming that if they are
4477 standard defying the frontend will catch them. */
4478 gfc_conv_expr (&se, c->expr);
4479 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4486 return gfc_build_null_descriptor (type);
4492 /* Create a constructor from the list of elements. */
4493 tmp = build_constructor (type, v);
4494 TREE_CONSTANT (tmp) = 1;
4499 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4500 returns the size (in elements) of the array. */
4503 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4504 stmtblock_t * pblock)
4519 size = gfc_index_one_node;
4520 offset = gfc_index_zero_node;
4521 for (dim = 0; dim < as->rank; dim++)
4523 /* Evaluate non-constant array bound expressions. */
4524 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4525 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4527 gfc_init_se (&se, NULL);
4528 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4529 gfc_add_block_to_block (pblock, &se.pre);
4530 gfc_add_modify (pblock, lbound, se.expr);
4532 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4533 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4535 gfc_init_se (&se, NULL);
4536 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4537 gfc_add_block_to_block (pblock, &se.pre);
4538 gfc_add_modify (pblock, ubound, se.expr);
4540 /* The offset of this dimension. offset = offset - lbound * stride. */
4541 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4543 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4546 /* The size of this dimension, and the stride of the next. */
4547 if (dim + 1 < as->rank)
4548 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4550 stride = GFC_TYPE_ARRAY_SIZE (type);
4552 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4554 /* Calculate stride = size * (ubound + 1 - lbound). */
4555 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4556 gfc_array_index_type,
4557 gfc_index_one_node, lbound);
4558 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4559 gfc_array_index_type, ubound, tmp);
4560 tmp = fold_build2_loc (input_location, MULT_EXPR,
4561 gfc_array_index_type, size, tmp);
4563 gfc_add_modify (pblock, stride, tmp);
4565 stride = gfc_evaluate_now (tmp, pblock);
4567 /* Make sure that negative size arrays are translated
4568 to being zero size. */
4569 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4570 stride, gfc_index_zero_node);
4571 tmp = fold_build3_loc (input_location, COND_EXPR,
4572 gfc_array_index_type, tmp,
4573 stride, gfc_index_zero_node);
4574 gfc_add_modify (pblock, stride, tmp);
4580 gfc_trans_vla_type_sizes (sym, pblock);
4587 /* Generate code to initialize/allocate an array variable. */
4590 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4591 gfc_wrapped_block * block)
4600 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4602 /* Do nothing for USEd variables. */
4603 if (sym->attr.use_assoc)
4606 type = TREE_TYPE (decl);
4607 gcc_assert (GFC_ARRAY_TYPE_P (type));
4608 onstack = TREE_CODE (type) != POINTER_TYPE;
4610 gfc_start_block (&init);
4612 /* Evaluate character string length. */
4613 if (sym->ts.type == BT_CHARACTER
4614 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4616 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4618 gfc_trans_vla_type_sizes (sym, &init);
4620 /* Emit a DECL_EXPR for this variable, which will cause the
4621 gimplifier to allocate storage, and all that good stuff. */
4622 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4623 gfc_add_expr_to_block (&init, tmp);
4628 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4632 type = TREE_TYPE (type);
4634 gcc_assert (!sym->attr.use_assoc);
4635 gcc_assert (!TREE_STATIC (decl));
4636 gcc_assert (!sym->module);
4638 if (sym->ts.type == BT_CHARACTER
4639 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4640 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4642 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4644 /* Don't actually allocate space for Cray Pointees. */
4645 if (sym->attr.cray_pointee)
4647 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4648 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4650 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4654 /* The size is the number of elements in the array, so multiply by the
4655 size of an element to get the total size. */
4656 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4657 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4658 size, fold_convert (gfc_array_index_type, tmp));
4660 /* Allocate memory to hold the data. */
4661 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4662 gfc_add_modify (&init, decl, tmp);
4664 /* Set offset of the array. */
4665 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4666 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4668 /* Automatic arrays should not have initializers. */
4669 gcc_assert (!sym->value);
4671 /* Free the temporary. */
4672 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4674 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4678 /* Generate entry and exit code for g77 calling convention arrays. */
4681 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4691 gfc_save_backend_locus (&loc);
4692 gfc_set_backend_locus (&sym->declared_at);
4694 /* Descriptor type. */
4695 parm = sym->backend_decl;
4696 type = TREE_TYPE (parm);
4697 gcc_assert (GFC_ARRAY_TYPE_P (type));
4699 gfc_start_block (&init);
4701 if (sym->ts.type == BT_CHARACTER
4702 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4703 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4705 /* Evaluate the bounds of the array. */
4706 gfc_trans_array_bounds (type, sym, &offset, &init);
4708 /* Set the offset. */
4709 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4710 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4712 /* Set the pointer itself if we aren't using the parameter directly. */
4713 if (TREE_CODE (parm) != PARM_DECL)
4715 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4716 gfc_add_modify (&init, parm, tmp);
4718 stmt = gfc_finish_block (&init);
4720 gfc_restore_backend_locus (&loc);
4722 /* Add the initialization code to the start of the function. */
4724 if (sym->attr.optional || sym->attr.not_always_present)
4726 tmp = gfc_conv_expr_present (sym);
4727 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4730 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4734 /* Modify the descriptor of an array parameter so that it has the
4735 correct lower bound. Also move the upper bound accordingly.
4736 If the array is not packed, it will be copied into a temporary.
4737 For each dimension we set the new lower and upper bounds. Then we copy the
4738 stride and calculate the offset for this dimension. We also work out
4739 what the stride of a packed array would be, and see it the two match.
4740 If the array need repacking, we set the stride to the values we just
4741 calculated, recalculate the offset and copy the array data.
4742 Code is also added to copy the data back at the end of the function.
4746 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4747 gfc_wrapped_block * block)
4754 tree stmtInit, stmtCleanup;
4761 tree stride, stride2;
4771 /* Do nothing for pointer and allocatable arrays. */
4772 if (sym->attr.pointer || sym->attr.allocatable)
4775 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4777 gfc_trans_g77_array (sym, block);
4781 gfc_save_backend_locus (&loc);
4782 gfc_set_backend_locus (&sym->declared_at);
4784 /* Descriptor type. */
4785 type = TREE_TYPE (tmpdesc);
4786 gcc_assert (GFC_ARRAY_TYPE_P (type));
4787 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4788 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4789 gfc_start_block (&init);
4791 if (sym->ts.type == BT_CHARACTER
4792 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4793 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4795 checkparm = (sym->as->type == AS_EXPLICIT
4796 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4798 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4799 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4801 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4803 /* For non-constant shape arrays we only check if the first dimension
4804 is contiguous. Repacking higher dimensions wouldn't gain us
4805 anything as we still don't know the array stride. */
4806 partial = gfc_create_var (boolean_type_node, "partial");
4807 TREE_USED (partial) = 1;
4808 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4809 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
4810 gfc_index_one_node);
4811 gfc_add_modify (&init, partial, tmp);
4814 partial = NULL_TREE;
4816 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4817 here, however I think it does the right thing. */
4820 /* Set the first stride. */
4821 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4822 stride = gfc_evaluate_now (stride, &init);
4824 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4825 stride, gfc_index_zero_node);
4826 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4827 tmp, gfc_index_one_node, stride);
4828 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4829 gfc_add_modify (&init, stride, tmp);
4831 /* Allow the user to disable array repacking. */
4832 stmt_unpacked = NULL_TREE;
4836 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4837 /* A library call to repack the array if necessary. */
4838 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4839 stmt_unpacked = build_call_expr_loc (input_location,
4840 gfor_fndecl_in_pack, 1, tmp);
4842 stride = gfc_index_one_node;
4844 if (gfc_option.warn_array_temp)
4845 gfc_warning ("Creating array temporary at %L", &loc);
4848 /* This is for the case where the array data is used directly without
4849 calling the repack function. */
4850 if (no_repack || partial != NULL_TREE)
4851 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4853 stmt_packed = NULL_TREE;
4855 /* Assign the data pointer. */
4856 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4858 /* Don't repack unknown shape arrays when the first stride is 1. */
4859 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
4860 partial, stmt_packed, stmt_unpacked);
4863 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4864 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
4866 offset = gfc_index_zero_node;
4867 size = gfc_index_one_node;
4869 /* Evaluate the bounds of the array. */
4870 for (n = 0; n < sym->as->rank; n++)
4872 if (checkparm || !sym->as->upper[n])
4874 /* Get the bounds of the actual parameter. */
4875 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4876 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4880 dubound = NULL_TREE;
4881 dlbound = NULL_TREE;
4884 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4885 if (!INTEGER_CST_P (lbound))
4887 gfc_init_se (&se, NULL);
4888 gfc_conv_expr_type (&se, sym->as->lower[n],
4889 gfc_array_index_type);
4890 gfc_add_block_to_block (&init, &se.pre);
4891 gfc_add_modify (&init, lbound, se.expr);
4894 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4895 /* Set the desired upper bound. */
4896 if (sym->as->upper[n])
4898 /* We know what we want the upper bound to be. */
4899 if (!INTEGER_CST_P (ubound))
4901 gfc_init_se (&se, NULL);
4902 gfc_conv_expr_type (&se, sym->as->upper[n],
4903 gfc_array_index_type);
4904 gfc_add_block_to_block (&init, &se.pre);
4905 gfc_add_modify (&init, ubound, se.expr);
4908 /* Check the sizes match. */
4911 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4915 temp = fold_build2_loc (input_location, MINUS_EXPR,
4916 gfc_array_index_type, ubound, lbound);
4917 temp = fold_build2_loc (input_location, PLUS_EXPR,
4918 gfc_array_index_type,
4919 gfc_index_one_node, temp);
4920 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
4921 gfc_array_index_type, dubound,
4923 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
4924 gfc_array_index_type,
4925 gfc_index_one_node, stride2);
4926 tmp = fold_build2_loc (input_location, NE_EXPR,
4927 gfc_array_index_type, temp, stride2);
4928 asprintf (&msg, "Dimension %d of array '%s' has extent "
4929 "%%ld instead of %%ld", n+1, sym->name);
4931 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
4932 fold_convert (long_integer_type_node, temp),
4933 fold_convert (long_integer_type_node, stride2));
4940 /* For assumed shape arrays move the upper bound by the same amount
4941 as the lower bound. */
4942 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4943 gfc_array_index_type, dubound, dlbound);
4944 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4945 gfc_array_index_type, tmp, lbound);
4946 gfc_add_modify (&init, ubound, tmp);
4948 /* The offset of this dimension. offset = offset - lbound * stride. */
4949 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4951 offset = fold_build2_loc (input_location, MINUS_EXPR,
4952 gfc_array_index_type, offset, tmp);
4954 /* The size of this dimension, and the stride of the next. */
4955 if (n + 1 < sym->as->rank)
4957 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4959 if (no_repack || partial != NULL_TREE)
4961 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4963 /* Figure out the stride if not a known constant. */
4964 if (!INTEGER_CST_P (stride))
4967 stmt_packed = NULL_TREE;
4970 /* Calculate stride = size * (ubound + 1 - lbound). */
4971 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4972 gfc_array_index_type,
4973 gfc_index_one_node, lbound);
4974 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4975 gfc_array_index_type, ubound, tmp);
4976 size = fold_build2_loc (input_location, MULT_EXPR,
4977 gfc_array_index_type, size, tmp);
4981 /* Assign the stride. */
4982 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4983 tmp = fold_build3_loc (input_location, COND_EXPR,
4984 gfc_array_index_type, partial,
4985 stmt_unpacked, stmt_packed);
4987 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4988 gfc_add_modify (&init, stride, tmp);
4993 stride = GFC_TYPE_ARRAY_SIZE (type);
4995 if (stride && !INTEGER_CST_P (stride))
4997 /* Calculate size = stride * (ubound + 1 - lbound). */
4998 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4999 gfc_array_index_type,
5000 gfc_index_one_node, lbound);
5001 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5002 gfc_array_index_type,
5004 tmp = fold_build2_loc (input_location, MULT_EXPR,
5005 gfc_array_index_type,
5006 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5007 gfc_add_modify (&init, stride, tmp);
5012 /* Set the offset. */
5013 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5014 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5016 gfc_trans_vla_type_sizes (sym, &init);
5018 stmtInit = gfc_finish_block (&init);
5020 /* Only do the entry/initialization code if the arg is present. */
5021 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5022 optional_arg = (sym->attr.optional
5023 || (sym->ns->proc_name->attr.entry_master
5024 && sym->attr.dummy));
5027 tmp = gfc_conv_expr_present (sym);
5028 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5029 build_empty_stmt (input_location));
5034 stmtCleanup = NULL_TREE;
5037 stmtblock_t cleanup;
5038 gfc_start_block (&cleanup);
5040 if (sym->attr.intent != INTENT_IN)
5042 /* Copy the data back. */
5043 tmp = build_call_expr_loc (input_location,
5044 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5045 gfc_add_expr_to_block (&cleanup, tmp);
5048 /* Free the temporary. */
5049 tmp = gfc_call_free (tmpdesc);
5050 gfc_add_expr_to_block (&cleanup, tmp);
5052 stmtCleanup = gfc_finish_block (&cleanup);
5054 /* Only do the cleanup if the array was repacked. */
5055 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5056 tmp = gfc_conv_descriptor_data_get (tmp);
5057 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5059 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5060 build_empty_stmt (input_location));
5064 tmp = gfc_conv_expr_present (sym);
5065 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5066 build_empty_stmt (input_location));
5070 /* We don't need to free any memory allocated by internal_pack as it will
5071 be freed at the end of the function by pop_context. */
5072 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5074 gfc_restore_backend_locus (&loc);
5078 /* Calculate the overall offset, including subreferences. */
5080 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5081 bool subref, gfc_expr *expr)
5091 /* If offset is NULL and this is not a subreferenced array, there is
5093 if (offset == NULL_TREE)
5096 offset = gfc_index_zero_node;
5101 tmp = gfc_conv_array_data (desc);
5102 tmp = build_fold_indirect_ref_loc (input_location,
5104 tmp = gfc_build_array_ref (tmp, offset, NULL);
5106 /* Offset the data pointer for pointer assignments from arrays with
5107 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5110 /* Go past the array reference. */
5111 for (ref = expr->ref; ref; ref = ref->next)
5112 if (ref->type == REF_ARRAY &&
5113 ref->u.ar.type != AR_ELEMENT)
5119 /* Calculate the offset for each subsequent subreference. */
5120 for (; ref; ref = ref->next)
5125 field = ref->u.c.component->backend_decl;
5126 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5127 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5129 tmp, field, NULL_TREE);
5133 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5134 gfc_init_se (&start, NULL);
5135 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5136 gfc_add_block_to_block (block, &start.pre);
5137 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5141 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5142 && ref->u.ar.type == AR_ELEMENT);
5144 /* TODO - Add bounds checking. */
5145 stride = gfc_index_one_node;
5146 index = gfc_index_zero_node;
5147 for (n = 0; n < ref->u.ar.dimen; n++)
5152 /* Update the index. */
5153 gfc_init_se (&start, NULL);
5154 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5155 itmp = gfc_evaluate_now (start.expr, block);
5156 gfc_init_se (&start, NULL);
5157 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5158 jtmp = gfc_evaluate_now (start.expr, block);
5159 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5160 gfc_array_index_type, itmp, jtmp);
5161 itmp = fold_build2_loc (input_location, MULT_EXPR,
5162 gfc_array_index_type, itmp, stride);
5163 index = fold_build2_loc (input_location, PLUS_EXPR,
5164 gfc_array_index_type, itmp, index);
5165 index = gfc_evaluate_now (index, block);
5167 /* Update the stride. */
5168 gfc_init_se (&start, NULL);
5169 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5170 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5171 gfc_array_index_type, start.expr,
5173 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5174 gfc_array_index_type,
5175 gfc_index_one_node, itmp);
5176 stride = fold_build2_loc (input_location, MULT_EXPR,
5177 gfc_array_index_type, stride, itmp);
5178 stride = gfc_evaluate_now (stride, block);
5181 /* Apply the index to obtain the array element. */
5182 tmp = gfc_build_array_ref (tmp, index, NULL);
5192 /* Set the target data pointer. */
5193 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5194 gfc_conv_descriptor_data_set (block, parm, offset);
5198 /* gfc_conv_expr_descriptor needs the string length an expression
5199 so that the size of the temporary can be obtained. This is done
5200 by adding up the string lengths of all the elements in the
5201 expression. Function with non-constant expressions have their
5202 string lengths mapped onto the actual arguments using the
5203 interface mapping machinery in trans-expr.c. */
5205 get_array_charlen (gfc_expr *expr, gfc_se *se)
5207 gfc_interface_mapping mapping;
5208 gfc_formal_arglist *formal;
5209 gfc_actual_arglist *arg;
5212 if (expr->ts.u.cl->length
5213 && gfc_is_constant_expr (expr->ts.u.cl->length))
5215 if (!expr->ts.u.cl->backend_decl)
5216 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5220 switch (expr->expr_type)
5223 get_array_charlen (expr->value.op.op1, se);
5225 /* For parentheses the expression ts.u.cl is identical. */
5226 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5229 expr->ts.u.cl->backend_decl =
5230 gfc_create_var (gfc_charlen_type_node, "sln");
5232 if (expr->value.op.op2)
5234 get_array_charlen (expr->value.op.op2, se);
5236 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5238 /* Add the string lengths and assign them to the expression
5239 string length backend declaration. */
5240 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5241 fold_build2_loc (input_location, PLUS_EXPR,
5242 gfc_charlen_type_node,
5243 expr->value.op.op1->ts.u.cl->backend_decl,
5244 expr->value.op.op2->ts.u.cl->backend_decl));
5247 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5248 expr->value.op.op1->ts.u.cl->backend_decl);
5252 if (expr->value.function.esym == NULL
5253 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5255 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5259 /* Map expressions involving the dummy arguments onto the actual
5260 argument expressions. */
5261 gfc_init_interface_mapping (&mapping);
5262 formal = expr->symtree->n.sym->formal;
5263 arg = expr->value.function.actual;
5265 /* Set se = NULL in the calls to the interface mapping, to suppress any
5267 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5272 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5275 gfc_init_se (&tse, NULL);
5277 /* Build the expression for the character length and convert it. */
5278 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5280 gfc_add_block_to_block (&se->pre, &tse.pre);
5281 gfc_add_block_to_block (&se->post, &tse.post);
5282 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5283 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5284 gfc_charlen_type_node, tse.expr,
5285 build_int_cst (gfc_charlen_type_node, 0));
5286 expr->ts.u.cl->backend_decl = tse.expr;
5287 gfc_free_interface_mapping (&mapping);
5291 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5296 /* Helper function to check dimensions. */
5298 dim_ok (gfc_ss_info *info)
5301 for (n = 0; n < info->dimen; n++)
5302 if (info->dim[n] != n)
5307 /* Convert an array for passing as an actual argument. Expressions and
5308 vector subscripts are evaluated and stored in a temporary, which is then
5309 passed. For whole arrays the descriptor is passed. For array sections
5310 a modified copy of the descriptor is passed, but using the original data.
5312 This function is also used for array pointer assignments, and there
5315 - se->want_pointer && !se->direct_byref
5316 EXPR is an actual argument. On exit, se->expr contains a
5317 pointer to the array descriptor.
5319 - !se->want_pointer && !se->direct_byref
5320 EXPR is an actual argument to an intrinsic function or the
5321 left-hand side of a pointer assignment. On exit, se->expr
5322 contains the descriptor for EXPR.
5324 - !se->want_pointer && se->direct_byref
5325 EXPR is the right-hand side of a pointer assignment and
5326 se->expr is the descriptor for the previously-evaluated
5327 left-hand side. The function creates an assignment from
5331 The se->force_tmp flag disables the non-copying descriptor optimization
5332 that is used for transpose. It may be used in cases where there is an
5333 alias between the transpose argument and another argument in the same
5337 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5349 bool subref_array_target = false;
5352 gcc_assert (ss != NULL);
5353 gcc_assert (ss != gfc_ss_terminator);
5355 /* Special case things we know we can pass easily. */
5356 switch (expr->expr_type)
5359 /* If we have a linear array section, we can pass it directly.
5360 Otherwise we need to copy it into a temporary. */
5362 gcc_assert (ss->type == GFC_SS_SECTION);
5363 gcc_assert (ss->expr == expr);
5364 info = &ss->data.info;
5366 /* Get the descriptor for the array. */
5367 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5368 desc = info->descriptor;
5370 subref_array_target = se->direct_byref && is_subref_array (expr);
5371 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5372 && !subref_array_target;
5379 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5381 /* Create a new descriptor if the array doesn't have one. */
5384 else if (info->ref->u.ar.type == AR_FULL)
5386 else if (se->direct_byref)
5389 full = gfc_full_array_ref_p (info->ref, NULL);
5391 if (full && dim_ok (info))
5393 if (se->direct_byref && !se->byref_noassign)
5395 /* Copy the descriptor for pointer assignments. */
5396 gfc_add_modify (&se->pre, se->expr, desc);
5398 /* Add any offsets from subreferences. */
5399 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5400 subref_array_target, expr);
5402 else if (se->want_pointer)
5404 /* We pass full arrays directly. This means that pointers and
5405 allocatable arrays should also work. */
5406 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5413 if (expr->ts.type == BT_CHARACTER)
5414 se->string_length = gfc_get_expr_charlen (expr);
5422 /* We don't need to copy data in some cases. */
5423 arg = gfc_get_noncopying_intrinsic_argument (expr);
5426 /* This is a call to transpose... */
5427 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5428 /* ... which has already been handled by the scalarizer, so
5429 that we just need to get its argument's descriptor. */
5430 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5434 /* A transformational function return value will be a temporary
5435 array descriptor. We still need to go through the scalarizer
5436 to create the descriptor. Elemental functions ar handled as
5437 arbitrary expressions, i.e. copy to a temporary. */
5439 if (se->direct_byref)
5441 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5443 /* For pointer assignments pass the descriptor directly. */
5447 gcc_assert (se->ss == ss);
5448 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5449 gfc_conv_expr (se, expr);
5453 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5455 if (ss->expr != expr)
5456 /* Elemental function. */
5457 gcc_assert ((expr->value.function.esym != NULL
5458 && expr->value.function.esym->attr.elemental)
5459 || (expr->value.function.isym != NULL
5460 && expr->value.function.isym->elemental));
5462 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5465 if (expr->ts.type == BT_CHARACTER
5466 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5467 get_array_charlen (expr, se);
5473 /* Transformational function. */
5474 info = &ss->data.info;
5480 /* Constant array constructors don't need a temporary. */
5481 if (ss->type == GFC_SS_CONSTRUCTOR
5482 && expr->ts.type != BT_CHARACTER
5483 && gfc_constant_array_constructor_p (expr->value.constructor))
5486 info = &ss->data.info;
5496 /* Something complicated. Copy it into a temporary. */
5502 /* If we are creating a temporary, we don't need to bother about aliases
5507 gfc_init_loopinfo (&loop);
5509 /* Associate the SS with the loop. */
5510 gfc_add_ss_to_loop (&loop, ss);
5512 /* Tell the scalarizer not to bother creating loop variables, etc. */
5514 loop.array_parameter = 1;
5516 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5517 gcc_assert (!se->direct_byref);
5519 /* Setup the scalarizing loops and bounds. */
5520 gfc_conv_ss_startstride (&loop);
5524 /* Tell the scalarizer to make a temporary. */
5525 loop.temp_ss = gfc_get_ss ();
5526 loop.temp_ss->type = GFC_SS_TEMP;
5527 loop.temp_ss->next = gfc_ss_terminator;
5529 if (expr->ts.type == BT_CHARACTER
5530 && !expr->ts.u.cl->backend_decl)
5531 get_array_charlen (expr, se);
5533 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5535 if (expr->ts.type == BT_CHARACTER)
5536 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5538 loop.temp_ss->string_length = NULL;
5540 se->string_length = loop.temp_ss->string_length;
5541 loop.temp_ss->data.temp.dimen = loop.dimen;
5542 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5545 gfc_conv_loop_setup (&loop, & expr->where);
5549 /* Copy into a temporary and pass that. We don't need to copy the data
5550 back because expressions and vector subscripts must be INTENT_IN. */
5551 /* TODO: Optimize passing function return values. */
5555 /* Start the copying loops. */
5556 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5557 gfc_mark_ss_chain_used (ss, 1);
5558 gfc_start_scalarized_body (&loop, &block);
5560 /* Copy each data element. */
5561 gfc_init_se (&lse, NULL);
5562 gfc_copy_loopinfo_to_se (&lse, &loop);
5563 gfc_init_se (&rse, NULL);
5564 gfc_copy_loopinfo_to_se (&rse, &loop);
5566 lse.ss = loop.temp_ss;
5569 gfc_conv_scalarized_array_ref (&lse, NULL);
5570 if (expr->ts.type == BT_CHARACTER)
5572 gfc_conv_expr (&rse, expr);
5573 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5574 rse.expr = build_fold_indirect_ref_loc (input_location,
5578 gfc_conv_expr_val (&rse, expr);
5580 gfc_add_block_to_block (&block, &rse.pre);
5581 gfc_add_block_to_block (&block, &lse.pre);
5583 lse.string_length = rse.string_length;
5584 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5585 expr->expr_type == EXPR_VARIABLE, true);
5586 gfc_add_expr_to_block (&block, tmp);
5588 /* Finish the copying loops. */
5589 gfc_trans_scalarizing_loops (&loop, &block);
5591 desc = loop.temp_ss->data.info.descriptor;
5593 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5595 desc = info->descriptor;
5596 se->string_length = ss->string_length;
5600 /* We pass sections without copying to a temporary. Make a new
5601 descriptor and point it at the section we want. The loop variable
5602 limits will be the limits of the section.
5603 A function may decide to repack the array to speed up access, but
5604 we're not bothered about that here. */
5613 /* Set the string_length for a character array. */
5614 if (expr->ts.type == BT_CHARACTER)
5615 se->string_length = gfc_get_expr_charlen (expr);
5617 desc = info->descriptor;
5618 if (se->direct_byref && !se->byref_noassign)
5620 /* For pointer assignments we fill in the destination. */
5622 parmtype = TREE_TYPE (parm);
5626 /* Otherwise make a new one. */
5627 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5628 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5629 loop.from, loop.to, 0,
5630 GFC_ARRAY_UNKNOWN, false);
5631 parm = gfc_create_var (parmtype, "parm");
5634 offset = gfc_index_zero_node;
5636 /* The following can be somewhat confusing. We have two
5637 descriptors, a new one and the original array.
5638 {parm, parmtype, dim} refer to the new one.
5639 {desc, type, n, loop} refer to the original, which maybe
5640 a descriptorless array.
5641 The bounds of the scalarization are the bounds of the section.
5642 We don't have to worry about numeric overflows when calculating
5643 the offsets because all elements are within the array data. */
5645 /* Set the dtype. */
5646 tmp = gfc_conv_descriptor_dtype (parm);
5647 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5649 /* Set offset for assignments to pointer only to zero if it is not
5651 if (se->direct_byref
5652 && info->ref && info->ref->u.ar.type != AR_FULL)
5653 base = gfc_index_zero_node;
5654 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5655 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5659 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5660 for (n = 0; n < ndim; n++)
5662 stride = gfc_conv_array_stride (desc, n);
5664 /* Work out the offset. */
5666 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5668 gcc_assert (info->subscript[n]
5669 && info->subscript[n]->type == GFC_SS_SCALAR);
5670 start = info->subscript[n]->data.scalar.expr;
5674 /* Evaluate and remember the start of the section. */
5675 start = info->start[n];
5676 stride = gfc_evaluate_now (stride, &loop.pre);
5679 tmp = gfc_conv_array_lbound (desc, n);
5680 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5682 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5684 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5688 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5690 /* For elemental dimensions, we only need the offset. */
5694 /* Vector subscripts need copying and are handled elsewhere. */
5696 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5698 /* look for the corresponding scalarizer dimension: dim. */
5699 for (dim = 0; dim < ndim; dim++)
5700 if (info->dim[dim] == n)
5703 /* loop exited early: the DIM being looked for has been found. */
5704 gcc_assert (dim < ndim);
5706 /* Set the new lower bound. */
5707 from = loop.from[dim];
5710 /* If we have an array section or are assigning make sure that
5711 the lower bound is 1. References to the full
5712 array should otherwise keep the original bounds. */
5714 || info->ref->u.ar.type != AR_FULL)
5715 && !integer_onep (from))
5717 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5718 gfc_array_index_type, gfc_index_one_node,
5720 to = fold_build2_loc (input_location, PLUS_EXPR,
5721 gfc_array_index_type, to, tmp);
5722 from = gfc_index_one_node;
5724 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5725 gfc_rank_cst[dim], from);
5727 /* Set the new upper bound. */
5728 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5729 gfc_rank_cst[dim], to);
5731 /* Multiply the stride by the section stride to get the
5733 stride = fold_build2_loc (input_location, MULT_EXPR,
5734 gfc_array_index_type,
5735 stride, info->stride[n]);
5737 if (se->direct_byref
5739 && info->ref->u.ar.type != AR_FULL)
5741 base = fold_build2_loc (input_location, MINUS_EXPR,
5742 TREE_TYPE (base), base, stride);
5744 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5746 tmp = gfc_conv_array_lbound (desc, n);
5747 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5748 TREE_TYPE (base), tmp, loop.from[dim]);
5749 tmp = fold_build2_loc (input_location, MULT_EXPR,
5750 TREE_TYPE (base), tmp,
5751 gfc_conv_array_stride (desc, n));
5752 base = fold_build2_loc (input_location, PLUS_EXPR,
5753 TREE_TYPE (base), tmp, base);
5756 /* Store the new stride. */
5757 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5758 gfc_rank_cst[dim], stride);
5761 if (se->data_not_needed)
5762 gfc_conv_descriptor_data_set (&loop.pre, parm,
5763 gfc_index_zero_node);
5765 /* Point the data pointer at the 1st element in the section. */
5766 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5767 subref_array_target, expr);
5769 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5770 && !se->data_not_needed)
5772 /* Set the offset. */
5773 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5777 /* Only the callee knows what the correct offset it, so just set
5779 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5784 if (!se->direct_byref || se->byref_noassign)
5786 /* Get a pointer to the new descriptor. */
5787 if (se->want_pointer)
5788 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5793 gfc_add_block_to_block (&se->pre, &loop.pre);
5794 gfc_add_block_to_block (&se->post, &loop.post);
5796 /* Cleanup the scalarizer. */
5797 gfc_cleanup_loop (&loop);
5800 /* Helper function for gfc_conv_array_parameter if array size needs to be
5804 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5807 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5808 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5809 else if (expr->rank > 1)
5810 *size = build_call_expr_loc (input_location,
5811 gfor_fndecl_size0, 1,
5812 gfc_build_addr_expr (NULL, desc));
5815 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5816 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5818 *size = fold_build2_loc (input_location, MINUS_EXPR,
5819 gfc_array_index_type, ubound, lbound);
5820 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5821 *size, gfc_index_one_node);
5822 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5823 *size, gfc_index_zero_node);
5825 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5826 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5827 *size, fold_convert (gfc_array_index_type, elem));
5830 /* Convert an array for passing as an actual parameter. */
5831 /* TODO: Optimize passing g77 arrays. */
5834 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5835 const gfc_symbol *fsym, const char *proc_name,
5840 tree tmp = NULL_TREE;
5842 tree parent = DECL_CONTEXT (current_function_decl);
5843 bool full_array_var;
5844 bool this_array_result;
5847 bool array_constructor;
5848 bool good_allocatable;
5849 bool ultimate_ptr_comp;
5850 bool ultimate_alloc_comp;
5855 ultimate_ptr_comp = false;
5856 ultimate_alloc_comp = false;
5858 for (ref = expr->ref; ref; ref = ref->next)
5860 if (ref->next == NULL)
5863 if (ref->type == REF_COMPONENT)
5865 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5866 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5870 full_array_var = false;
5873 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5874 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5876 sym = full_array_var ? expr->symtree->n.sym : NULL;
5878 /* The symbol should have an array specification. */
5879 gcc_assert (!sym || sym->as || ref->u.ar.as);
5881 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5883 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5884 expr->ts.u.cl->backend_decl = tmp;
5885 se->string_length = tmp;
5888 /* Is this the result of the enclosing procedure? */
5889 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5890 if (this_array_result
5891 && (sym->backend_decl != current_function_decl)
5892 && (sym->backend_decl != parent))
5893 this_array_result = false;
5895 /* Passing address of the array if it is not pointer or assumed-shape. */
5896 if (full_array_var && g77 && !this_array_result)
5898 tmp = gfc_get_symbol_decl (sym);
5900 if (sym->ts.type == BT_CHARACTER)
5901 se->string_length = sym->ts.u.cl->backend_decl;
5903 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
5905 gfc_conv_expr_descriptor (se, expr, ss);
5906 se->expr = gfc_conv_array_data (se->expr);
5910 if (!sym->attr.pointer
5912 && sym->as->type != AS_ASSUMED_SHAPE
5913 && !sym->attr.allocatable)
5915 /* Some variables are declared directly, others are declared as
5916 pointers and allocated on the heap. */
5917 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5920 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5922 array_parameter_size (tmp, expr, size);
5926 if (sym->attr.allocatable)
5928 if (sym->attr.dummy || sym->attr.result)
5930 gfc_conv_expr_descriptor (se, expr, ss);
5934 array_parameter_size (tmp, expr, size);
5935 se->expr = gfc_conv_array_data (tmp);
5940 /* A convenient reduction in scope. */
5941 contiguous = g77 && !this_array_result && contiguous;
5943 /* There is no need to pack and unpack the array, if it is contiguous
5944 and not a deferred- or assumed-shape array, or if it is simply
5946 no_pack = ((sym && sym->as
5947 && !sym->attr.pointer
5948 && sym->as->type != AS_DEFERRED
5949 && sym->as->type != AS_ASSUMED_SHAPE)
5951 (ref && ref->u.ar.as
5952 && ref->u.ar.as->type != AS_DEFERRED
5953 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
5955 gfc_is_simply_contiguous (expr, false));
5957 no_pack = contiguous && no_pack;
5959 /* Array constructors are always contiguous and do not need packing. */
5960 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5962 /* Same is true of contiguous sections from allocatable variables. */
5963 good_allocatable = contiguous
5965 && expr->symtree->n.sym->attr.allocatable;
5967 /* Or ultimate allocatable components. */
5968 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5970 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5972 gfc_conv_expr_descriptor (se, expr, ss);
5973 if (expr->ts.type == BT_CHARACTER)
5974 se->string_length = expr->ts.u.cl->backend_decl;
5976 array_parameter_size (se->expr, expr, size);
5977 se->expr = gfc_conv_array_data (se->expr);
5981 if (this_array_result)
5983 /* Result of the enclosing function. */
5984 gfc_conv_expr_descriptor (se, expr, ss);
5986 array_parameter_size (se->expr, expr, size);
5987 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5989 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5990 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5991 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5998 /* Every other type of array. */
5999 se->want_pointer = 1;
6000 gfc_conv_expr_descriptor (se, expr, ss);
6002 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6007 /* Deallocate the allocatable components of structures that are
6009 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6010 && expr->ts.u.derived->attr.alloc_comp
6011 && expr->expr_type != EXPR_VARIABLE)
6013 tmp = build_fold_indirect_ref_loc (input_location,
6015 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6016 gfc_add_expr_to_block (&se->post, tmp);
6019 if (g77 || (fsym && fsym->attr.contiguous
6020 && !gfc_is_simply_contiguous (expr, false)))
6022 tree origptr = NULL_TREE;
6026 /* For contiguous arrays, save the original value of the descriptor. */
6029 origptr = gfc_create_var (pvoid_type_node, "origptr");
6030 tmp = build_fold_indirect_ref_loc (input_location, desc);
6031 tmp = gfc_conv_array_data (tmp);
6032 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6033 TREE_TYPE (origptr), origptr,
6034 fold_convert (TREE_TYPE (origptr), tmp));
6035 gfc_add_expr_to_block (&se->pre, tmp);
6038 /* Repack the array. */
6039 if (gfc_option.warn_array_temp)
6042 gfc_warning ("Creating array temporary at %L for argument '%s'",
6043 &expr->where, fsym->name);
6045 gfc_warning ("Creating array temporary at %L", &expr->where);
6048 ptr = build_call_expr_loc (input_location,
6049 gfor_fndecl_in_pack, 1, desc);
6051 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6053 tmp = gfc_conv_expr_present (sym);
6054 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6055 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6056 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6059 ptr = gfc_evaluate_now (ptr, &se->pre);
6061 /* Use the packed data for the actual argument, except for contiguous arrays,
6062 where the descriptor's data component is set. */
6067 tmp = build_fold_indirect_ref_loc (input_location, desc);
6068 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6071 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6075 if (fsym && proc_name)
6076 asprintf (&msg, "An array temporary was created for argument "
6077 "'%s' of procedure '%s'", fsym->name, proc_name);
6079 asprintf (&msg, "An array temporary was created");
6081 tmp = build_fold_indirect_ref_loc (input_location,
6083 tmp = gfc_conv_array_data (tmp);
6084 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6085 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6087 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6088 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6090 gfc_conv_expr_present (sym), tmp);
6092 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6097 gfc_start_block (&block);
6099 /* Copy the data back. */
6100 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6102 tmp = build_call_expr_loc (input_location,
6103 gfor_fndecl_in_unpack, 2, desc, ptr);
6104 gfc_add_expr_to_block (&block, tmp);
6107 /* Free the temporary. */
6108 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6109 gfc_add_expr_to_block (&block, tmp);
6111 stmt = gfc_finish_block (&block);
6113 gfc_init_block (&block);
6114 /* Only if it was repacked. This code needs to be executed before the
6115 loop cleanup code. */
6116 tmp = build_fold_indirect_ref_loc (input_location,
6118 tmp = gfc_conv_array_data (tmp);
6119 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6120 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6122 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6123 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6125 gfc_conv_expr_present (sym), tmp);
6127 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6129 gfc_add_expr_to_block (&block, tmp);
6130 gfc_add_block_to_block (&block, &se->post);
6132 gfc_init_block (&se->post);
6134 /* Reset the descriptor pointer. */
6137 tmp = build_fold_indirect_ref_loc (input_location, desc);
6138 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6141 gfc_add_block_to_block (&se->post, &block);
6146 /* Generate code to deallocate an array, if it is allocated. */
6149 gfc_trans_dealloc_allocated (tree descriptor)
6155 gfc_start_block (&block);
6157 var = gfc_conv_descriptor_data_get (descriptor);
6160 /* Call array_deallocate with an int * present in the second argument.
6161 Although it is ignored here, it's presence ensures that arrays that
6162 are already deallocated are ignored. */
6163 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6164 gfc_add_expr_to_block (&block, tmp);
6166 /* Zero the data pointer. */
6167 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6168 var, build_int_cst (TREE_TYPE (var), 0));
6169 gfc_add_expr_to_block (&block, tmp);
6171 return gfc_finish_block (&block);
6175 /* This helper function calculates the size in words of a full array. */
6178 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6183 idx = gfc_rank_cst[rank - 1];
6184 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6185 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6186 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6188 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6189 tmp, gfc_index_one_node);
6190 tmp = gfc_evaluate_now (tmp, block);
6192 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6193 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6195 return gfc_evaluate_now (tmp, block);
6199 /* Allocate dest to the same size as src, and copy src -> dest.
6200 If no_malloc is set, only the copy is done. */
6203 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6213 /* If the source is null, set the destination to null. Then,
6214 allocate memory to the destination. */
6215 gfc_init_block (&block);
6219 tmp = null_pointer_node;
6220 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6221 gfc_add_expr_to_block (&block, tmp);
6222 null_data = gfc_finish_block (&block);
6224 gfc_init_block (&block);
6225 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6228 tmp = gfc_call_malloc (&block, type, size);
6229 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6230 dest, fold_convert (type, tmp));
6231 gfc_add_expr_to_block (&block, tmp);
6234 tmp = built_in_decls[BUILT_IN_MEMCPY];
6235 tmp = build_call_expr_loc (input_location, tmp, 3,
6240 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6241 null_data = gfc_finish_block (&block);
6243 gfc_init_block (&block);
6244 nelems = get_full_array_size (&block, src, rank);
6245 tmp = fold_convert (gfc_array_index_type,
6246 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6247 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6251 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6252 tmp = gfc_call_malloc (&block, tmp, size);
6253 gfc_conv_descriptor_data_set (&block, dest, tmp);
6256 /* We know the temporary and the value will be the same length,
6257 so can use memcpy. */
6258 tmp = built_in_decls[BUILT_IN_MEMCPY];
6259 tmp = build_call_expr_loc (input_location,
6260 tmp, 3, gfc_conv_descriptor_data_get (dest),
6261 gfc_conv_descriptor_data_get (src), size);
6264 gfc_add_expr_to_block (&block, tmp);
6265 tmp = gfc_finish_block (&block);
6267 /* Null the destination if the source is null; otherwise do
6268 the allocate and copy. */
6272 null_cond = gfc_conv_descriptor_data_get (src);
6274 null_cond = convert (pvoid_type_node, null_cond);
6275 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6276 null_cond, null_pointer_node);
6277 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6281 /* Allocate dest to the same size as src, and copy data src -> dest. */
6284 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6286 return duplicate_allocatable (dest, src, type, rank, false);
6290 /* Copy data src -> dest. */
6293 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6295 return duplicate_allocatable (dest, src, type, rank, true);
6299 /* Recursively traverse an object of derived type, generating code to
6300 deallocate, nullify or copy allocatable components. This is the work horse
6301 function for the functions named in this enum. */
6303 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6304 COPY_ONLY_ALLOC_COMP};
6307 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6308 tree dest, int rank, int purpose)
6312 stmtblock_t fnblock;
6313 stmtblock_t loopbody;
6324 tree null_cond = NULL_TREE;
6326 gfc_init_block (&fnblock);
6328 decl_type = TREE_TYPE (decl);
6330 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6331 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6333 decl = build_fold_indirect_ref_loc (input_location,
6336 /* Just in case in gets dereferenced. */
6337 decl_type = TREE_TYPE (decl);
6339 /* If this an array of derived types with allocatable components
6340 build a loop and recursively call this function. */
6341 if (TREE_CODE (decl_type) == ARRAY_TYPE
6342 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6344 tmp = gfc_conv_array_data (decl);
6345 var = build_fold_indirect_ref_loc (input_location,
6348 /* Get the number of elements - 1 and set the counter. */
6349 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6351 /* Use the descriptor for an allocatable array. Since this
6352 is a full array reference, we only need the descriptor
6353 information from dimension = rank. */
6354 tmp = get_full_array_size (&fnblock, decl, rank);
6355 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6356 gfc_array_index_type, tmp,
6357 gfc_index_one_node);
6359 null_cond = gfc_conv_descriptor_data_get (decl);
6360 null_cond = fold_build2_loc (input_location, NE_EXPR,
6361 boolean_type_node, null_cond,
6362 build_int_cst (TREE_TYPE (null_cond), 0));
6366 /* Otherwise use the TYPE_DOMAIN information. */
6367 tmp = array_type_nelts (decl_type);
6368 tmp = fold_convert (gfc_array_index_type, tmp);
6371 /* Remember that this is, in fact, the no. of elements - 1. */
6372 nelems = gfc_evaluate_now (tmp, &fnblock);
6373 index = gfc_create_var (gfc_array_index_type, "S");
6375 /* Build the body of the loop. */
6376 gfc_init_block (&loopbody);
6378 vref = gfc_build_array_ref (var, index, NULL);
6380 if (purpose == COPY_ALLOC_COMP)
6382 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6384 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6385 gfc_add_expr_to_block (&fnblock, tmp);
6387 tmp = build_fold_indirect_ref_loc (input_location,
6388 gfc_conv_array_data (dest));
6389 dref = gfc_build_array_ref (tmp, index, NULL);
6390 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6392 else if (purpose == COPY_ONLY_ALLOC_COMP)
6394 tmp = build_fold_indirect_ref_loc (input_location,
6395 gfc_conv_array_data (dest));
6396 dref = gfc_build_array_ref (tmp, index, NULL);
6397 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6401 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6403 gfc_add_expr_to_block (&loopbody, tmp);
6405 /* Build the loop and return. */
6406 gfc_init_loopinfo (&loop);
6408 loop.from[0] = gfc_index_zero_node;
6409 loop.loopvar[0] = index;
6410 loop.to[0] = nelems;
6411 gfc_trans_scalarizing_loops (&loop, &loopbody);
6412 gfc_add_block_to_block (&fnblock, &loop.pre);
6414 tmp = gfc_finish_block (&fnblock);
6415 if (null_cond != NULL_TREE)
6416 tmp = build3_v (COND_EXPR, null_cond, tmp,
6417 build_empty_stmt (input_location));
6422 /* Otherwise, act on the components or recursively call self to
6423 act on a chain of components. */
6424 for (c = der_type->components; c; c = c->next)
6426 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6427 || c->ts.type == BT_CLASS)
6428 && c->ts.u.derived->attr.alloc_comp;
6429 cdecl = c->backend_decl;
6430 ctype = TREE_TYPE (cdecl);
6434 case DEALLOCATE_ALLOC_COMP:
6435 if (c->attr.allocatable && c->attr.dimension)
6437 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6438 decl, cdecl, NULL_TREE);
6439 if (cmp_has_alloc_comps && !c->attr.pointer)
6441 /* Do not deallocate the components of ultimate pointer
6443 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6444 c->as->rank, purpose);
6445 gfc_add_expr_to_block (&fnblock, tmp);
6447 tmp = gfc_trans_dealloc_allocated (comp);
6448 gfc_add_expr_to_block (&fnblock, tmp);
6450 else if (c->attr.allocatable)
6452 /* Allocatable scalar components. */
6453 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6454 decl, cdecl, NULL_TREE);
6456 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6458 gfc_add_expr_to_block (&fnblock, tmp);
6460 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6461 void_type_node, comp,
6462 build_int_cst (TREE_TYPE (comp), 0));
6463 gfc_add_expr_to_block (&fnblock, tmp);
6465 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6467 /* Allocatable scalar CLASS components. */
6468 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6469 decl, cdecl, NULL_TREE);
6471 /* Add reference to '_data' component. */
6472 tmp = CLASS_DATA (c)->backend_decl;
6473 comp = fold_build3_loc (input_location, COMPONENT_REF,
6474 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6476 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6477 CLASS_DATA (c)->ts);
6478 gfc_add_expr_to_block (&fnblock, tmp);
6480 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6481 void_type_node, comp,
6482 build_int_cst (TREE_TYPE (comp), 0));
6483 gfc_add_expr_to_block (&fnblock, tmp);
6487 case NULLIFY_ALLOC_COMP:
6488 if (c->attr.pointer)
6490 else if (c->attr.allocatable && c->attr.dimension)
6492 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6493 decl, cdecl, NULL_TREE);
6494 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6496 else if (c->attr.allocatable)
6498 /* Allocatable scalar components. */
6499 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6500 decl, cdecl, NULL_TREE);
6501 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6502 void_type_node, comp,
6503 build_int_cst (TREE_TYPE (comp), 0));
6504 gfc_add_expr_to_block (&fnblock, tmp);
6506 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6508 /* Allocatable scalar CLASS components. */
6509 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6510 decl, cdecl, NULL_TREE);
6511 /* Add reference to '_data' component. */
6512 tmp = CLASS_DATA (c)->backend_decl;
6513 comp = fold_build3_loc (input_location, COMPONENT_REF,
6514 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6515 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6516 void_type_node, comp,
6517 build_int_cst (TREE_TYPE (comp), 0));
6518 gfc_add_expr_to_block (&fnblock, tmp);
6520 else if (cmp_has_alloc_comps)
6522 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6523 decl, cdecl, NULL_TREE);
6524 rank = c->as ? c->as->rank : 0;
6525 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6527 gfc_add_expr_to_block (&fnblock, tmp);
6531 case COPY_ALLOC_COMP:
6532 if (c->attr.pointer)
6535 /* We need source and destination components. */
6536 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6538 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6540 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6542 if (c->attr.allocatable && !cmp_has_alloc_comps)
6544 rank = c->as ? c->as->rank : 0;
6545 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6546 gfc_add_expr_to_block (&fnblock, tmp);
6549 if (cmp_has_alloc_comps)
6551 rank = c->as ? c->as->rank : 0;
6552 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6553 gfc_add_modify (&fnblock, dcmp, tmp);
6554 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6556 gfc_add_expr_to_block (&fnblock, tmp);
6566 return gfc_finish_block (&fnblock);
6569 /* Recursively traverse an object of derived type, generating code to
6570 nullify allocatable components. */
6573 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6575 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6576 NULLIFY_ALLOC_COMP);
6580 /* Recursively traverse an object of derived type, generating code to
6581 deallocate allocatable components. */
6584 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6586 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6587 DEALLOCATE_ALLOC_COMP);
6591 /* Recursively traverse an object of derived type, generating code to
6592 copy it and its allocatable components. */
6595 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6597 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6601 /* Recursively traverse an object of derived type, generating code to
6602 copy only its allocatable components. */
6605 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6607 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6611 /* Returns the value of LBOUND for an expression. This could be broken out
6612 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6613 called by gfc_alloc_allocatable_for_assignment. */
6615 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6620 tree cond, cond1, cond3, cond4;
6622 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6624 tmp = gfc_rank_cst[dim];
6625 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6626 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6627 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6628 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6630 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6631 stride, gfc_index_zero_node);
6632 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6633 boolean_type_node, cond3, cond1);
6634 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6635 stride, gfc_index_zero_node);
6637 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6638 tmp, build_int_cst (gfc_array_index_type,
6641 cond = boolean_false_node;
6643 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6644 boolean_type_node, cond3, cond4);
6645 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6646 boolean_type_node, cond, cond1);
6648 return fold_build3_loc (input_location, COND_EXPR,
6649 gfc_array_index_type, cond,
6650 lbound, gfc_index_one_node);
6652 else if (expr->expr_type == EXPR_VARIABLE)
6654 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6655 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
6657 else if (expr->expr_type == EXPR_FUNCTION)
6659 /* A conversion function, so use the argument. */
6660 expr = expr->value.function.actual->expr;
6661 if (expr->expr_type != EXPR_VARIABLE)
6662 return gfc_index_one_node;
6663 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6664 return get_std_lbound (expr, desc, dim, assumed_size);
6667 return gfc_index_one_node;
6671 /* Returns true if an expression represents an lhs that can be reallocated
6675 gfc_is_reallocatable_lhs (gfc_expr *expr)
6682 /* An allocatable variable. */
6683 if (expr->symtree->n.sym->attr.allocatable
6685 && expr->ref->type == REF_ARRAY
6686 && expr->ref->u.ar.type == AR_FULL)
6689 /* All that can be left are allocatable components. */
6690 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6691 && expr->symtree->n.sym->ts.type != BT_CLASS)
6692 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6695 /* Find a component ref followed by an array reference. */
6696 for (ref = expr->ref; ref; ref = ref->next)
6698 && ref->type == REF_COMPONENT
6699 && ref->next->type == REF_ARRAY
6700 && !ref->next->next)
6706 /* Return true if valid reallocatable lhs. */
6707 if (ref->u.c.component->attr.allocatable
6708 && ref->next->u.ar.type == AR_FULL)
6715 /* Allocate the lhs of an assignment to an allocatable array, otherwise
6719 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
6723 stmtblock_t realloc_block;
6724 stmtblock_t alloc_block;
6747 gfc_array_spec * as;
6749 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
6750 Find the lhs expression in the loop chain and set expr1 and
6751 expr2 accordingly. */
6752 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
6755 /* Find the ss for the lhs. */
6757 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6758 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
6760 if (lss == gfc_ss_terminator)
6765 /* Bail out if this is not a valid allocate on assignment. */
6766 if (!gfc_is_reallocatable_lhs (expr1)
6767 || (expr2 && !expr2->rank))
6770 /* Find the ss for the lhs. */
6772 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6773 if (lss->expr == expr1)
6776 if (lss == gfc_ss_terminator)
6779 /* Find an ss for the rhs. For operator expressions, we see the
6780 ss's for the operands. Any one of these will do. */
6782 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
6783 if (rss->expr != expr1 && rss != loop->temp_ss)
6786 if (expr2 && rss == gfc_ss_terminator)
6789 gfc_start_block (&fblock);
6791 /* Since the lhs is allocatable, this must be a descriptor type.
6792 Get the data and array size. */
6793 desc = lss->data.info.descriptor;
6794 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
6795 array1 = gfc_conv_descriptor_data_get (desc);
6796 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
6798 /* Get the rhs size. Fix both sizes. */
6800 desc2 = rss->data.info.descriptor;
6803 size2 = gfc_index_one_node;
6804 for (n = 0; n < expr2->rank; n++)
6806 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6807 gfc_array_index_type,
6808 loop->to[n], loop->from[n]);
6809 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6810 gfc_array_index_type,
6811 tmp, gfc_index_one_node);
6812 size2 = fold_build2_loc (input_location, MULT_EXPR,
6813 gfc_array_index_type,
6816 size1 = gfc_evaluate_now (size1, &fblock);
6817 size2 = gfc_evaluate_now (size2, &fblock);
6818 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6820 neq_size = gfc_evaluate_now (cond, &fblock);
6822 /* If the lhs is allocated and the lhs and rhs are equal length, jump
6823 past the realloc/malloc. This allows F95 compliant expressions
6824 to escape allocation on assignment. */
6825 jump_label1 = gfc_build_label_decl (NULL_TREE);
6826 jump_label2 = gfc_build_label_decl (NULL_TREE);
6828 /* Allocate if data is NULL. */
6829 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6830 array1, build_int_cst (TREE_TYPE (array1), 0));
6831 tmp = build3_v (COND_EXPR, cond,
6832 build1_v (GOTO_EXPR, jump_label1),
6833 build_empty_stmt (input_location));
6834 gfc_add_expr_to_block (&fblock, tmp);
6836 /* Reallocate if sizes are different. */
6837 tmp = build3_v (COND_EXPR, neq_size,
6838 build1_v (GOTO_EXPR, jump_label1),
6839 build_empty_stmt (input_location));
6840 gfc_add_expr_to_block (&fblock, tmp);
6842 if (expr2 && expr2->expr_type == EXPR_FUNCTION
6843 && expr2->value.function.isym
6844 && expr2->value.function.isym->conversion)
6846 /* For conversion functions, take the arg. */
6847 gfc_expr *arg = expr2->value.function.actual->expr;
6848 as = gfc_get_full_arrayspec_from_expr (arg);
6851 as = gfc_get_full_arrayspec_from_expr (expr2);
6855 /* Reset the lhs bounds if any are different from the rhs. */
6856 if (as && expr2->expr_type == EXPR_VARIABLE)
6858 for (n = 0; n < expr1->rank; n++)
6860 /* First check the lbounds. */
6861 dim = rss->data.info.dim[n];
6862 lbd = get_std_lbound (expr2, desc2, dim,
6863 as->type == AS_ASSUMED_SIZE);
6864 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6865 cond = fold_build2_loc (input_location, NE_EXPR,
6866 boolean_type_node, lbd, lbound);
6867 tmp = build3_v (COND_EXPR, cond,
6868 build1_v (GOTO_EXPR, jump_label1),
6869 build_empty_stmt (input_location));
6870 gfc_add_expr_to_block (&fblock, tmp);
6872 /* Now check the shape. */
6873 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6874 gfc_array_index_type,
6875 loop->to[n], loop->from[n]);
6876 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6877 gfc_array_index_type,
6879 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
6880 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6881 gfc_array_index_type,
6883 cond = fold_build2_loc (input_location, NE_EXPR,
6885 tmp, gfc_index_zero_node);
6886 tmp = build3_v (COND_EXPR, cond,
6887 build1_v (GOTO_EXPR, jump_label1),
6888 build_empty_stmt (input_location));
6889 gfc_add_expr_to_block (&fblock, tmp);
6893 /* Otherwise jump past the (re)alloc code. */
6894 tmp = build1_v (GOTO_EXPR, jump_label2);
6895 gfc_add_expr_to_block (&fblock, tmp);
6897 /* Add the label to start automatic (re)allocation. */
6898 tmp = build1_v (LABEL_EXPR, jump_label1);
6899 gfc_add_expr_to_block (&fblock, tmp);
6901 /* Now modify the lhs descriptor and the associated scalarizer
6903 7.4.1.3: If variable is or becomes an unallocated allocatable
6904 variable, then it is allocated with each deferred type parameter
6905 equal to the corresponding type parameters of expr , with the
6906 shape of expr , and with each lower bound equal to the
6907 corresponding element of LBOUND(expr). */
6908 size1 = gfc_index_one_node;
6909 offset = gfc_index_zero_node;
6911 for (n = 0; n < expr2->rank; n++)
6913 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6914 gfc_array_index_type,
6915 loop->to[n], loop->from[n]);
6916 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6917 gfc_array_index_type,
6918 tmp, gfc_index_one_node);
6920 lbound = gfc_index_one_node;
6925 lbd = get_std_lbound (expr2, desc2, n,
6926 as->type == AS_ASSUMED_SIZE);
6927 ubound = fold_build2_loc (input_location,
6929 gfc_array_index_type,
6931 ubound = fold_build2_loc (input_location,
6933 gfc_array_index_type,
6938 gfc_conv_descriptor_lbound_set (&fblock, desc,
6941 gfc_conv_descriptor_ubound_set (&fblock, desc,
6944 gfc_conv_descriptor_stride_set (&fblock, desc,
6947 lbound = gfc_conv_descriptor_lbound_get (desc,
6949 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
6950 gfc_array_index_type,
6952 offset = fold_build2_loc (input_location, MINUS_EXPR,
6953 gfc_array_index_type,
6955 size1 = fold_build2_loc (input_location, MULT_EXPR,
6956 gfc_array_index_type,
6960 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
6961 the array offset is saved and the info.offset is used for a
6962 running offset. Use the saved_offset instead. */
6963 tmp = gfc_conv_descriptor_offset (desc);
6964 gfc_add_modify (&fblock, tmp, offset);
6965 if (lss->data.info.saved_offset
6966 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
6967 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
6969 /* Now set the deltas for the lhs. */
6970 for (n = 0; n < expr1->rank; n++)
6972 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
6973 dim = lss->data.info.dim[n];
6974 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6975 gfc_array_index_type, tmp,
6977 if (lss->data.info.delta[dim]
6978 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
6979 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
6982 /* Get the new lhs size in bytes. */
6983 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
6985 tmp = expr2->ts.u.cl->backend_decl;
6986 gcc_assert (expr1->ts.u.cl->backend_decl);
6987 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
6988 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
6990 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
6992 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
6993 tmp = fold_build2_loc (input_location, MULT_EXPR,
6994 gfc_array_index_type, tmp,
6995 expr1->ts.u.cl->backend_decl);
6998 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
6999 tmp = fold_convert (gfc_array_index_type, tmp);
7000 size2 = fold_build2_loc (input_location, MULT_EXPR,
7001 gfc_array_index_type,
7003 size2 = fold_convert (size_type_node, size2);
7004 size2 = gfc_evaluate_now (size2, &fblock);
7006 /* Realloc expression. Note that the scalarizer uses desc.data
7007 in the array reference - (*desc.data)[<element>]. */
7008 gfc_init_block (&realloc_block);
7009 tmp = build_call_expr_loc (input_location,
7010 built_in_decls[BUILT_IN_REALLOC], 2,
7011 fold_convert (pvoid_type_node, array1),
7013 gfc_conv_descriptor_data_set (&realloc_block,
7015 realloc_expr = gfc_finish_block (&realloc_block);
7017 /* Only reallocate if sizes are different. */
7018 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7019 build_empty_stmt (input_location));
7023 /* Malloc expression. */
7024 gfc_init_block (&alloc_block);
7025 tmp = build_call_expr_loc (input_location,
7026 built_in_decls[BUILT_IN_MALLOC], 1,
7028 gfc_conv_descriptor_data_set (&alloc_block,
7030 tmp = gfc_conv_descriptor_dtype (desc);
7031 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7032 alloc_expr = gfc_finish_block (&alloc_block);
7034 /* Malloc if not allocated; realloc otherwise. */
7035 tmp = build_int_cst (TREE_TYPE (array1), 0);
7036 cond = fold_build2_loc (input_location, EQ_EXPR,
7039 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7040 gfc_add_expr_to_block (&fblock, tmp);
7042 /* Make sure that the scalarizer data pointer is updated. */
7043 if (lss->data.info.data
7044 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7046 tmp = gfc_conv_descriptor_data_get (desc);
7047 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7050 /* Add the exit label. */
7051 tmp = build1_v (LABEL_EXPR, jump_label2);
7052 gfc_add_expr_to_block (&fblock, tmp);
7054 return gfc_finish_block (&fblock);
7058 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7059 Do likewise, recursively if necessary, with the allocatable components of
7063 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7069 stmtblock_t cleanup;
7072 bool sym_has_alloc_comp;
7074 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7075 || sym->ts.type == BT_CLASS)
7076 && sym->ts.u.derived->attr.alloc_comp;
7078 /* Make sure the frontend gets these right. */
7079 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7080 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7081 "allocatable attribute or derived type without allocatable "
7084 gfc_init_block (&init);
7086 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7087 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7089 if (sym->ts.type == BT_CHARACTER
7090 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7092 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7093 gfc_trans_vla_type_sizes (sym, &init);
7096 /* Dummy, use associated and result variables don't need anything special. */
7097 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7099 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7103 gfc_save_backend_locus (&loc);
7104 gfc_set_backend_locus (&sym->declared_at);
7105 descriptor = sym->backend_decl;
7107 /* Although static, derived types with default initializers and
7108 allocatable components must not be nulled wholesale; instead they
7109 are treated component by component. */
7110 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7112 /* SAVEd variables are not freed on exit. */
7113 gfc_trans_static_array_pointer (sym);
7115 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7116 gfc_restore_backend_locus (&loc);
7120 /* Get the descriptor type. */
7121 type = TREE_TYPE (sym->backend_decl);
7123 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7126 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7128 if (sym->value == NULL
7129 || !gfc_has_default_initializer (sym->ts.u.derived))
7131 rank = sym->as ? sym->as->rank : 0;
7132 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7134 gfc_add_expr_to_block (&init, tmp);
7137 gfc_init_default_dt (sym, &init, false);
7140 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7142 /* If the backend_decl is not a descriptor, we must have a pointer
7144 descriptor = build_fold_indirect_ref_loc (input_location,
7146 type = TREE_TYPE (descriptor);
7149 /* NULLIFY the data pointer. */
7150 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7151 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7153 gfc_init_block (&cleanup);
7154 gfc_restore_backend_locus (&loc);
7156 /* Allocatable arrays need to be freed when they go out of scope.
7157 The allocatable components of pointers must not be touched. */
7158 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7159 && !sym->attr.pointer && !sym->attr.save)
7162 rank = sym->as ? sym->as->rank : 0;
7163 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7164 gfc_add_expr_to_block (&cleanup, tmp);
7167 if (sym->attr.allocatable && sym->attr.dimension
7168 && !sym->attr.save && !sym->attr.result)
7170 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7171 gfc_add_expr_to_block (&cleanup, tmp);
7174 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7175 gfc_finish_block (&cleanup));
7178 /************ Expression Walking Functions ******************/
7180 /* Walk a variable reference.
7182 Possible extension - multiple component subscripts.
7183 x(:,:) = foo%a(:)%b(:)
7185 forall (i=..., j=...)
7186 x(i,j) = foo%a(j)%b(i)
7188 This adds a fair amount of complexity because you need to deal with more
7189 than one ref. Maybe handle in a similar manner to vector subscripts.
7190 Maybe not worth the effort. */
7194 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7201 for (ref = expr->ref; ref; ref = ref->next)
7202 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7205 for (; ref; ref = ref->next)
7207 if (ref->type == REF_SUBSTRING)
7209 newss = gfc_get_ss ();
7210 newss->type = GFC_SS_SCALAR;
7211 newss->expr = ref->u.ss.start;
7215 newss = gfc_get_ss ();
7216 newss->type = GFC_SS_SCALAR;
7217 newss->expr = ref->u.ss.end;
7222 /* We're only interested in array sections from now on. */
7223 if (ref->type != REF_ARRAY)
7228 if (ar->as->rank == 0)
7230 /* Scalar coarray. */
7237 for (n = 0; n < ar->dimen; n++)
7239 newss = gfc_get_ss ();
7240 newss->type = GFC_SS_SCALAR;
7241 newss->expr = ar->start[n];
7248 newss = gfc_get_ss ();
7249 newss->type = GFC_SS_SECTION;
7252 newss->data.info.dimen = ar->as->rank;
7253 newss->data.info.ref = ref;
7255 /* Make sure array is the same as array(:,:), this way
7256 we don't need to special case all the time. */
7257 ar->dimen = ar->as->rank;
7258 for (n = 0; n < ar->dimen; n++)
7260 newss->data.info.dim[n] = n;
7261 ar->dimen_type[n] = DIMEN_RANGE;
7263 gcc_assert (ar->start[n] == NULL);
7264 gcc_assert (ar->end[n] == NULL);
7265 gcc_assert (ar->stride[n] == NULL);
7271 newss = gfc_get_ss ();
7272 newss->type = GFC_SS_SECTION;
7275 newss->data.info.dimen = 0;
7276 newss->data.info.ref = ref;
7278 /* We add SS chains for all the subscripts in the section. */
7279 for (n = 0; n < ar->dimen; n++)
7283 switch (ar->dimen_type[n])
7286 /* Add SS for elemental (scalar) subscripts. */
7287 gcc_assert (ar->start[n]);
7288 indexss = gfc_get_ss ();
7289 indexss->type = GFC_SS_SCALAR;
7290 indexss->expr = ar->start[n];
7291 indexss->next = gfc_ss_terminator;
7292 indexss->loop_chain = gfc_ss_terminator;
7293 newss->data.info.subscript[n] = indexss;
7297 /* We don't add anything for sections, just remember this
7298 dimension for later. */
7299 newss->data.info.dim[newss->data.info.dimen] = n;
7300 newss->data.info.dimen++;
7304 /* Create a GFC_SS_VECTOR index in which we can store
7305 the vector's descriptor. */
7306 indexss = gfc_get_ss ();
7307 indexss->type = GFC_SS_VECTOR;
7308 indexss->expr = ar->start[n];
7309 indexss->next = gfc_ss_terminator;
7310 indexss->loop_chain = gfc_ss_terminator;
7311 newss->data.info.subscript[n] = indexss;
7312 newss->data.info.dim[newss->data.info.dimen] = n;
7313 newss->data.info.dimen++;
7317 /* We should know what sort of section it is by now. */
7321 /* We should have at least one non-elemental dimension. */
7322 gcc_assert (newss->data.info.dimen > 0);
7327 /* We should know what sort of section it is by now. */
7336 /* Walk an expression operator. If only one operand of a binary expression is
7337 scalar, we must also add the scalar term to the SS chain. */
7340 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7346 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7347 if (expr->value.op.op2 == NULL)
7350 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7352 /* All operands are scalar. Pass back and let the caller deal with it. */
7356 /* All operands require scalarization. */
7357 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7360 /* One of the operands needs scalarization, the other is scalar.
7361 Create a gfc_ss for the scalar expression. */
7362 newss = gfc_get_ss ();
7363 newss->type = GFC_SS_SCALAR;
7366 /* First operand is scalar. We build the chain in reverse order, so
7367 add the scalar SS after the second operand. */
7369 while (head && head->next != ss)
7371 /* Check we haven't somehow broken the chain. */
7375 newss->expr = expr->value.op.op1;
7377 else /* head2 == head */
7379 gcc_assert (head2 == head);
7380 /* Second operand is scalar. */
7381 newss->next = head2;
7383 newss->expr = expr->value.op.op2;
7390 /* Reverse a SS chain. */
7393 gfc_reverse_ss (gfc_ss * ss)
7398 gcc_assert (ss != NULL);
7400 head = gfc_ss_terminator;
7401 while (ss != gfc_ss_terminator)
7404 /* Check we didn't somehow break the chain. */
7405 gcc_assert (next != NULL);
7415 /* Walk the arguments of an elemental function. */
7418 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7426 head = gfc_ss_terminator;
7429 for (; arg; arg = arg->next)
7434 newss = gfc_walk_subexpr (head, arg->expr);
7437 /* Scalar argument. */
7438 newss = gfc_get_ss ();
7440 newss->expr = arg->expr;
7450 while (tail->next != gfc_ss_terminator)
7457 /* If all the arguments are scalar we don't need the argument SS. */
7458 gfc_free_ss_chain (head);
7463 /* Add it onto the existing chain. */
7469 /* Walk a function call. Scalar functions are passed back, and taken out of
7470 scalarization loops. For elemental functions we walk their arguments.
7471 The result of functions returning arrays is stored in a temporary outside
7472 the loop, so that the function is only called once. Hence we do not need
7473 to walk their arguments. */
7476 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7479 gfc_intrinsic_sym *isym;
7481 gfc_component *comp = NULL;
7484 isym = expr->value.function.isym;
7486 /* Handle intrinsic functions separately. */
7488 return gfc_walk_intrinsic_function (ss, expr, isym);
7490 sym = expr->value.function.esym;
7492 sym = expr->symtree->n.sym;
7494 /* A function that returns arrays. */
7495 gfc_is_proc_ptr_comp (expr, &comp);
7496 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7497 || (comp && comp->attr.dimension))
7499 newss = gfc_get_ss ();
7500 newss->type = GFC_SS_FUNCTION;
7503 newss->data.info.dimen = expr->rank;
7504 for (n = 0; n < newss->data.info.dimen; n++)
7505 newss->data.info.dim[n] = n;
7509 /* Walk the parameters of an elemental function. For now we always pass
7511 if (sym->attr.elemental)
7512 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7515 /* Scalar functions are OK as these are evaluated outside the scalarization
7516 loop. Pass back and let the caller deal with it. */
7521 /* An array temporary is constructed for array constructors. */
7524 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7529 newss = gfc_get_ss ();
7530 newss->type = GFC_SS_CONSTRUCTOR;
7533 newss->data.info.dimen = expr->rank;
7534 for (n = 0; n < expr->rank; n++)
7535 newss->data.info.dim[n] = n;
7541 /* Walk an expression. Add walked expressions to the head of the SS chain.
7542 A wholly scalar expression will not be added. */
7545 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7549 switch (expr->expr_type)
7552 head = gfc_walk_variable_expr (ss, expr);
7556 head = gfc_walk_op_expr (ss, expr);
7560 head = gfc_walk_function_expr (ss, expr);
7565 case EXPR_STRUCTURE:
7566 /* Pass back and let the caller deal with it. */
7570 head = gfc_walk_array_constructor (ss, expr);
7573 case EXPR_SUBSTRING:
7574 /* Pass back and let the caller deal with it. */
7578 internal_error ("bad expression type during walk (%d)",
7585 /* Entry point for expression walking.
7586 A return value equal to the passed chain means this is
7587 a scalar expression. It is up to the caller to take whatever action is
7588 necessary to translate these. */
7591 gfc_walk_expr (gfc_expr * expr)
7595 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7596 return gfc_reverse_ss (res);