1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
85 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
88 #include "constructor.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var;
100 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 gfc_array_dataptr_type (tree desc)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
132 #define CAF_TOKEN_FIELD 4
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
172 type = TREE_TYPE (desc);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
175 field = TYPE_FIELDS (type);
176 gcc_assert (DATA_FIELD == 0);
178 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
200 return gfc_build_addr_expr (NULL_TREE, t);
204 gfc_conv_descriptor_offset (tree desc)
209 type = TREE_TYPE (desc);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
212 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
213 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
215 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
216 desc, field, NULL_TREE);
220 gfc_conv_descriptor_offset_get (tree desc)
222 return gfc_conv_descriptor_offset (desc);
226 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
229 tree t = gfc_conv_descriptor_offset (desc);
230 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
235 gfc_conv_descriptor_dtype (tree desc)
240 type = TREE_TYPE (desc);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
243 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
244 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
246 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
247 desc, field, NULL_TREE);
251 gfc_conv_descriptor_dimension (tree desc, tree dim)
257 type = TREE_TYPE (desc);
258 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
260 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
261 gcc_assert (field != NULL_TREE
262 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
263 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
265 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
266 desc, field, NULL_TREE);
267 tmp = gfc_build_array_ref (tmp, dim, NULL);
273 gfc_conv_descriptor_token (tree desc)
278 type = TREE_TYPE (desc);
279 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
280 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
281 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
282 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
284 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
285 desc, field, NULL_TREE);
290 gfc_conv_descriptor_stride (tree desc, tree dim)
295 tmp = gfc_conv_descriptor_dimension (desc, dim);
296 field = TYPE_FIELDS (TREE_TYPE (tmp));
297 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
298 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
300 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
301 tmp, field, NULL_TREE);
306 gfc_conv_descriptor_stride_get (tree desc, tree dim)
308 tree type = TREE_TYPE (desc);
309 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
310 if (integer_zerop (dim)
311 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
312 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
313 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
314 return gfc_index_one_node;
316 return gfc_conv_descriptor_stride (desc, dim);
320 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
321 tree dim, tree value)
323 tree t = gfc_conv_descriptor_stride (desc, dim);
324 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
328 gfc_conv_descriptor_lbound (tree desc, tree dim)
333 tmp = gfc_conv_descriptor_dimension (desc, dim);
334 field = TYPE_FIELDS (TREE_TYPE (tmp));
335 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
336 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
338 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
339 tmp, field, NULL_TREE);
344 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
346 return gfc_conv_descriptor_lbound (desc, dim);
350 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
351 tree dim, tree value)
353 tree t = gfc_conv_descriptor_lbound (desc, dim);
354 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
358 gfc_conv_descriptor_ubound (tree desc, tree dim)
363 tmp = gfc_conv_descriptor_dimension (desc, dim);
364 field = TYPE_FIELDS (TREE_TYPE (tmp));
365 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
366 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
368 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
369 tmp, field, NULL_TREE);
374 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
376 return gfc_conv_descriptor_ubound (desc, dim);
380 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
381 tree dim, tree value)
383 tree t = gfc_conv_descriptor_ubound (desc, dim);
384 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
387 /* Build a null array descriptor constructor. */
390 gfc_build_null_descriptor (tree type)
395 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
396 gcc_assert (DATA_FIELD == 0);
397 field = TYPE_FIELDS (type);
399 /* Set a NULL data pointer. */
400 tmp = build_constructor_single (type, field, null_pointer_node);
401 TREE_CONSTANT (tmp) = 1;
402 /* All other fields are ignored. */
408 /* Modify a descriptor such that the lbound of a given dimension is the value
409 specified. This also updates ubound and offset accordingly. */
412 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
413 int dim, tree new_lbound)
415 tree offs, ubound, lbound, stride;
416 tree diff, offs_diff;
418 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
420 offs = gfc_conv_descriptor_offset_get (desc);
421 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
422 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
423 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
425 /* Get difference (new - old) by which to shift stuff. */
426 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
429 /* Shift ubound and offset accordingly. This has to be done before
430 updating the lbound, as they depend on the lbound expression! */
431 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
433 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
434 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
436 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
438 gfc_conv_descriptor_offset_set (block, desc, offs);
440 /* Finally set lbound to value we want. */
441 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
445 /* Cleanup those #defines. */
450 #undef DIMENSION_FIELD
451 #undef CAF_TOKEN_FIELD
452 #undef STRIDE_SUBFIELD
453 #undef LBOUND_SUBFIELD
454 #undef UBOUND_SUBFIELD
457 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
458 flags & 1 = Main loop body.
459 flags & 2 = temp copy loop. */
462 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
464 for (; ss != gfc_ss_terminator; ss = ss->next)
465 ss->useflags = flags;
468 static void gfc_free_ss (gfc_ss *);
471 /* Free a gfc_ss chain. */
474 gfc_free_ss_chain (gfc_ss * ss)
478 while (ss != gfc_ss_terminator)
480 gcc_assert (ss != NULL);
491 gfc_free_ss (gfc_ss * ss)
498 for (n = 0; n < ss->data.info.dimen; n++)
500 if (ss->data.info.subscript[ss->data.info.dim[n]])
501 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
513 /* Free all the SS associated with a loop. */
516 gfc_cleanup_loop (gfc_loopinfo * loop)
522 while (ss != gfc_ss_terminator)
524 gcc_assert (ss != NULL);
525 next = ss->loop_chain;
532 /* Associate a SS chain with a loop. */
535 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
539 if (head == gfc_ss_terminator)
543 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
545 if (ss->next == gfc_ss_terminator)
546 ss->loop_chain = loop->ss;
548 ss->loop_chain = ss->next;
550 gcc_assert (ss == gfc_ss_terminator);
555 /* Generate an initializer for a static pointer or allocatable array. */
558 gfc_trans_static_array_pointer (gfc_symbol * sym)
562 gcc_assert (TREE_STATIC (sym->backend_decl));
563 /* Just zero the data member. */
564 type = TREE_TYPE (sym->backend_decl);
565 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
569 /* If the bounds of SE's loop have not yet been set, see if they can be
570 determined from array spec AS, which is the array spec of a called
571 function. MAPPING maps the callee's dummy arguments to the values
572 that the caller is passing. Add any initialization and finalization
576 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
577 gfc_se * se, gfc_array_spec * as)
585 if (as && as->type == AS_EXPLICIT)
586 for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
588 dim = se->ss->data.info.dim[n];
589 gcc_assert (dim < as->rank);
590 gcc_assert (se->loop->dimen == as->rank);
591 if (se->loop->to[n] == NULL_TREE)
593 /* Evaluate the lower bound. */
594 gfc_init_se (&tmpse, NULL);
595 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
596 gfc_add_block_to_block (&se->pre, &tmpse.pre);
597 gfc_add_block_to_block (&se->post, &tmpse.post);
598 lower = fold_convert (gfc_array_index_type, tmpse.expr);
600 if (se->loop->codimen == 0
601 || n < se->loop->dimen + se->loop->codimen - 1)
603 /* ...and the upper bound. */
604 gfc_init_se (&tmpse, NULL);
605 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
606 gfc_add_block_to_block (&se->pre, &tmpse.pre);
607 gfc_add_block_to_block (&se->post, &tmpse.post);
608 upper = fold_convert (gfc_array_index_type, tmpse.expr);
610 /* Set the upper bound of the loop to UPPER - LOWER. */
611 tmp = fold_build2_loc (input_location, MINUS_EXPR,
612 gfc_array_index_type, upper, lower);
613 tmp = gfc_evaluate_now (tmp, &se->pre);
614 se->loop->to[n] = tmp;
621 /* Generate code to allocate an array temporary, or create a variable to
622 hold the data. If size is NULL, zero the descriptor so that the
623 callee will allocate the array. If DEALLOC is true, also generate code to
624 free the array afterwards.
626 If INITIAL is not NULL, it is packed using internal_pack and the result used
627 as data instead of allocating a fresh, unitialized area of memory.
629 Initialization code is added to PRE and finalization code to POST.
630 DYNAMIC is true if the caller may want to extend the array later
631 using realloc. This prevents us from putting the array on the stack. */
634 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
635 gfc_ss_info * info, tree size, tree nelem,
636 tree initial, bool dynamic, bool dealloc)
642 desc = info->descriptor;
643 info->offset = gfc_index_zero_node;
644 if (size == NULL_TREE || integer_zerop (size))
646 /* A callee allocated array. */
647 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
652 /* Allocate the temporary. */
653 onstack = !dynamic && initial == NULL_TREE
654 && (gfc_option.flag_stack_arrays
655 || gfc_can_put_var_on_stack (size));
659 /* Make a temporary variable to hold the data. */
660 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
661 nelem, gfc_index_one_node);
662 tmp = gfc_evaluate_now (tmp, pre);
663 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
665 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
667 tmp = gfc_create_var (tmp, "A");
668 /* If we're here only because of -fstack-arrays we have to
669 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
670 if (!gfc_can_put_var_on_stack (size))
671 gfc_add_expr_to_block (pre,
672 fold_build1_loc (input_location,
673 DECL_EXPR, TREE_TYPE (tmp),
675 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
676 gfc_conv_descriptor_data_set (pre, desc, tmp);
680 /* Allocate memory to hold the data or call internal_pack. */
681 if (initial == NULL_TREE)
683 tmp = gfc_call_malloc (pre, NULL, size);
684 tmp = gfc_evaluate_now (tmp, pre);
691 stmtblock_t do_copying;
693 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
694 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
695 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
696 tmp = gfc_get_element_type (tmp);
697 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
698 packed = gfc_create_var (build_pointer_type (tmp), "data");
700 tmp = build_call_expr_loc (input_location,
701 gfor_fndecl_in_pack, 1, initial);
702 tmp = fold_convert (TREE_TYPE (packed), tmp);
703 gfc_add_modify (pre, packed, tmp);
705 tmp = build_fold_indirect_ref_loc (input_location,
707 source_data = gfc_conv_descriptor_data_get (tmp);
709 /* internal_pack may return source->data without any allocation
710 or copying if it is already packed. If that's the case, we
711 need to allocate and copy manually. */
713 gfc_start_block (&do_copying);
714 tmp = gfc_call_malloc (&do_copying, NULL, size);
715 tmp = fold_convert (TREE_TYPE (packed), tmp);
716 gfc_add_modify (&do_copying, packed, tmp);
717 tmp = gfc_build_memcpy_call (packed, source_data, size);
718 gfc_add_expr_to_block (&do_copying, tmp);
720 was_packed = fold_build2_loc (input_location, EQ_EXPR,
721 boolean_type_node, packed,
723 tmp = gfc_finish_block (&do_copying);
724 tmp = build3_v (COND_EXPR, was_packed, tmp,
725 build_empty_stmt (input_location));
726 gfc_add_expr_to_block (pre, tmp);
728 tmp = fold_convert (pvoid_type_node, packed);
731 gfc_conv_descriptor_data_set (pre, desc, tmp);
734 info->data = gfc_conv_descriptor_data_get (desc);
736 /* The offset is zero because we create temporaries with a zero
738 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
740 if (dealloc && !onstack)
742 /* Free the temporary. */
743 tmp = gfc_conv_descriptor_data_get (desc);
744 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
745 gfc_add_expr_to_block (post, tmp);
750 /* Get the array reference dimension corresponding to the given loop dimension.
751 It is different from the true array dimension given by the dim array in
752 the case of a partial array reference
753 It is different from the loop dimension in the case of a transposed array.
757 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
759 int n, array_dim, array_ref_dim;
762 array_dim = info->dim[loop_dim];
764 for (n = 0; n < info->dimen; n++)
765 if (n != loop_dim && info->dim[n] < array_dim)
768 return array_ref_dim;
772 /* Generate code to create and initialize the descriptor for a temporary
773 array. This is used for both temporaries needed by the scalarizer, and
774 functions returning arrays. Adjusts the loop variables to be
775 zero-based, and calculates the loop bounds for callee allocated arrays.
776 Allocate the array unless it's callee allocated (we have a callee
777 allocated array if 'callee_alloc' is true, or if loop->to[n] is
778 NULL_TREE for any n). Also fills in the descriptor, data and offset
779 fields of info if known. Returns the size of the array, or NULL for a
780 callee allocated array.
782 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
783 gfc_trans_allocate_array_storage.
787 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
788 gfc_loopinfo * loop, gfc_ss_info * info,
789 tree eltype, tree initial, bool dynamic,
790 bool dealloc, bool callee_alloc, locus * where)
792 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
802 memset (from, 0, sizeof (from));
803 memset (to, 0, sizeof (to));
805 gcc_assert (info->dimen > 0);
806 gcc_assert (loop->dimen == info->dimen);
808 if (gfc_option.warn_array_temp && where)
809 gfc_warning ("Creating array temporary at %L", where);
811 /* Set the lower bound to zero. */
812 for (n = 0; n < loop->dimen; n++)
816 /* Callee allocated arrays may not have a known bound yet. */
818 loop->to[n] = gfc_evaluate_now (
819 fold_build2_loc (input_location, MINUS_EXPR,
820 gfc_array_index_type,
821 loop->to[n], loop->from[n]),
823 loop->from[n] = gfc_index_zero_node;
825 /* We are constructing the temporary's descriptor based on the loop
826 dimensions. As the dimensions may be accessed in arbitrary order
827 (think of transpose) the size taken from the n'th loop may not map
828 to the n'th dimension of the array. We need to reconstruct loop infos
829 in the right order before using it to set the descriptor
831 tmp_dim = get_array_ref_dim (info, n);
832 from[tmp_dim] = loop->from[n];
833 to[tmp_dim] = loop->to[n];
835 info->delta[dim] = gfc_index_zero_node;
836 info->start[dim] = gfc_index_zero_node;
837 info->end[dim] = gfc_index_zero_node;
838 info->stride[dim] = gfc_index_one_node;
841 /* Initialize the descriptor. */
843 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
844 GFC_ARRAY_UNKNOWN, true);
845 desc = gfc_create_var (type, "atmp");
846 GFC_DECL_PACKED_ARRAY (desc) = 1;
848 info->descriptor = desc;
849 size = gfc_index_one_node;
851 /* Fill in the array dtype. */
852 tmp = gfc_conv_descriptor_dtype (desc);
853 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
856 Fill in the bounds and stride. This is a packed array, so:
859 for (n = 0; n < rank; n++)
862 delta = ubound[n] + 1 - lbound[n];
865 size = size * sizeof(element);
870 /* If there is at least one null loop->to[n], it is a callee allocated
872 for (n = 0; n < loop->dimen; n++)
873 if (loop->to[n] == NULL_TREE)
879 for (n = 0; n < loop->dimen; n++)
883 if (size == NULL_TREE)
885 /* For a callee allocated array express the loop bounds in terms
886 of the descriptor fields. */
887 tmp = fold_build2_loc (input_location,
888 MINUS_EXPR, gfc_array_index_type,
889 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
890 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
895 /* Store the stride and bound components in the descriptor. */
896 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
898 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
899 gfc_index_zero_node);
901 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
904 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
905 to[n], gfc_index_one_node);
907 /* Check whether the size for this dimension is negative. */
908 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
909 gfc_index_zero_node);
910 cond = gfc_evaluate_now (cond, pre);
915 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
916 boolean_type_node, or_expr, cond);
918 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
920 size = gfc_evaluate_now (size, pre);
922 for (n = info->dimen; n < info->dimen + info->codimen; n++)
924 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
925 gfc_index_zero_node);
926 if (n < info->dimen + info->codimen - 1)
927 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
930 /* Get the size of the array. */
932 if (size && !callee_alloc)
934 /* If or_expr is true, then the extent in at least one
935 dimension is zero and the size is set to zero. */
936 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
937 or_expr, gfc_index_zero_node, size);
940 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
942 fold_convert (gfc_array_index_type,
943 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
951 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
954 if (info->dimen > loop->temp_dim)
955 loop->temp_dim = info->dimen;
961 /* Return the number of iterations in a loop that starts at START,
962 ends at END, and has step STEP. */
965 gfc_get_iteration_count (tree start, tree end, tree step)
970 type = TREE_TYPE (step);
971 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
972 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
973 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
974 build_int_cst (type, 1));
975 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
976 build_int_cst (type, 0));
977 return fold_convert (gfc_array_index_type, tmp);
981 /* Extend the data in array DESC by EXTRA elements. */
984 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
991 if (integer_zerop (extra))
994 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
996 /* Add EXTRA to the upper bound. */
997 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
999 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1001 /* Get the value of the current data pointer. */
1002 arg0 = gfc_conv_descriptor_data_get (desc);
1004 /* Calculate the new array size. */
1005 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1006 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1007 ubound, gfc_index_one_node);
1008 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1009 fold_convert (size_type_node, tmp),
1010 fold_convert (size_type_node, size));
1012 /* Call the realloc() function. */
1013 tmp = gfc_call_realloc (pblock, arg0, arg1);
1014 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1018 /* Return true if the bounds of iterator I can only be determined
1022 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1024 return (i->start->expr_type != EXPR_CONSTANT
1025 || i->end->expr_type != EXPR_CONSTANT
1026 || i->step->expr_type != EXPR_CONSTANT);
1030 /* Split the size of constructor element EXPR into the sum of two terms,
1031 one of which can be determined at compile time and one of which must
1032 be calculated at run time. Set *SIZE to the former and return true
1033 if the latter might be nonzero. */
1036 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1038 if (expr->expr_type == EXPR_ARRAY)
1039 return gfc_get_array_constructor_size (size, expr->value.constructor);
1040 else if (expr->rank > 0)
1042 /* Calculate everything at run time. */
1043 mpz_set_ui (*size, 0);
1048 /* A single element. */
1049 mpz_set_ui (*size, 1);
1055 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1056 of array constructor C. */
1059 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1067 mpz_set_ui (*size, 0);
1072 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1075 if (i && gfc_iterator_has_dynamic_bounds (i))
1079 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1082 /* Multiply the static part of the element size by the
1083 number of iterations. */
1084 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1085 mpz_fdiv_q (val, val, i->step->value.integer);
1086 mpz_add_ui (val, val, 1);
1087 if (mpz_sgn (val) > 0)
1088 mpz_mul (len, len, val);
1090 mpz_set_ui (len, 0);
1092 mpz_add (*size, *size, len);
1101 /* Make sure offset is a variable. */
1104 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1107 /* We should have already created the offset variable. We cannot
1108 create it here because we may be in an inner scope. */
1109 gcc_assert (*offsetvar != NULL_TREE);
1110 gfc_add_modify (pblock, *offsetvar, *poffset);
1111 *poffset = *offsetvar;
1112 TREE_USED (*offsetvar) = 1;
1116 /* Variables needed for bounds-checking. */
1117 static bool first_len;
1118 static tree first_len_val;
1119 static bool typespec_chararray_ctor;
1122 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1123 tree offset, gfc_se * se, gfc_expr * expr)
1127 gfc_conv_expr (se, expr);
1129 /* Store the value. */
1130 tmp = build_fold_indirect_ref_loc (input_location,
1131 gfc_conv_descriptor_data_get (desc));
1132 tmp = gfc_build_array_ref (tmp, offset, NULL);
1134 if (expr->ts.type == BT_CHARACTER)
1136 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1139 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1140 esize = fold_convert (gfc_charlen_type_node, esize);
1141 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1142 gfc_charlen_type_node, esize,
1143 build_int_cst (gfc_charlen_type_node,
1144 gfc_character_kinds[i].bit_size / 8));
1146 gfc_conv_string_parameter (se);
1147 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1149 /* The temporary is an array of pointers. */
1150 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1151 gfc_add_modify (&se->pre, tmp, se->expr);
1155 /* The temporary is an array of string values. */
1156 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1157 /* We know the temporary and the value will be the same length,
1158 so can use memcpy. */
1159 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1160 se->string_length, se->expr, expr->ts.kind);
1162 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1166 gfc_add_modify (&se->pre, first_len_val,
1172 /* Verify that all constructor elements are of the same
1174 tree cond = fold_build2_loc (input_location, NE_EXPR,
1175 boolean_type_node, first_len_val,
1177 gfc_trans_runtime_check
1178 (true, false, cond, &se->pre, &expr->where,
1179 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1180 fold_convert (long_integer_type_node, first_len_val),
1181 fold_convert (long_integer_type_node, se->string_length));
1187 /* TODO: Should the frontend already have done this conversion? */
1188 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1189 gfc_add_modify (&se->pre, tmp, se->expr);
1192 gfc_add_block_to_block (pblock, &se->pre);
1193 gfc_add_block_to_block (pblock, &se->post);
1197 /* Add the contents of an array to the constructor. DYNAMIC is as for
1198 gfc_trans_array_constructor_value. */
1201 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1202 tree type ATTRIBUTE_UNUSED,
1203 tree desc, gfc_expr * expr,
1204 tree * poffset, tree * offsetvar,
1215 /* We need this to be a variable so we can increment it. */
1216 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1218 gfc_init_se (&se, NULL);
1220 /* Walk the array expression. */
1221 ss = gfc_walk_expr (expr);
1222 gcc_assert (ss != gfc_ss_terminator);
1224 /* Initialize the scalarizer. */
1225 gfc_init_loopinfo (&loop);
1226 gfc_add_ss_to_loop (&loop, ss);
1228 /* Initialize the loop. */
1229 gfc_conv_ss_startstride (&loop);
1230 gfc_conv_loop_setup (&loop, &expr->where);
1232 /* Make sure the constructed array has room for the new data. */
1235 /* Set SIZE to the total number of elements in the subarray. */
1236 size = gfc_index_one_node;
1237 for (n = 0; n < loop.dimen; n++)
1239 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1240 gfc_index_one_node);
1241 size = fold_build2_loc (input_location, MULT_EXPR,
1242 gfc_array_index_type, size, tmp);
1245 /* Grow the constructed array by SIZE elements. */
1246 gfc_grow_array (&loop.pre, desc, size);
1249 /* Make the loop body. */
1250 gfc_mark_ss_chain_used (ss, 1);
1251 gfc_start_scalarized_body (&loop, &body);
1252 gfc_copy_loopinfo_to_se (&se, &loop);
1255 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1256 gcc_assert (se.ss == gfc_ss_terminator);
1258 /* Increment the offset. */
1259 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1260 *poffset, gfc_index_one_node);
1261 gfc_add_modify (&body, *poffset, tmp);
1263 /* Finish the loop. */
1264 gfc_trans_scalarizing_loops (&loop, &body);
1265 gfc_add_block_to_block (&loop.pre, &loop.post);
1266 tmp = gfc_finish_block (&loop.pre);
1267 gfc_add_expr_to_block (pblock, tmp);
1269 gfc_cleanup_loop (&loop);
1273 /* Assign the values to the elements of an array constructor. DYNAMIC
1274 is true if descriptor DESC only contains enough data for the static
1275 size calculated by gfc_get_array_constructor_size. When true, memory
1276 for the dynamic parts must be allocated using realloc. */
1279 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1280 tree desc, gfc_constructor_base base,
1281 tree * poffset, tree * offsetvar,
1290 tree shadow_loopvar = NULL_TREE;
1291 gfc_saved_var saved_loopvar;
1294 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1296 /* If this is an iterator or an array, the offset must be a variable. */
1297 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1298 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1300 /* Shadowing the iterator avoids changing its value and saves us from
1301 keeping track of it. Further, it makes sure that there's always a
1302 backend-decl for the symbol, even if there wasn't one before,
1303 e.g. in the case of an iterator that appears in a specification
1304 expression in an interface mapping. */
1307 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1308 tree type = gfc_typenode_for_spec (&sym->ts);
1310 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1311 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1314 gfc_start_block (&body);
1316 if (c->expr->expr_type == EXPR_ARRAY)
1318 /* Array constructors can be nested. */
1319 gfc_trans_array_constructor_value (&body, type, desc,
1320 c->expr->value.constructor,
1321 poffset, offsetvar, dynamic);
1323 else if (c->expr->rank > 0)
1325 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1326 poffset, offsetvar, dynamic);
1330 /* This code really upsets the gimplifier so don't bother for now. */
1337 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1339 p = gfc_constructor_next (p);
1344 /* Scalar values. */
1345 gfc_init_se (&se, NULL);
1346 gfc_trans_array_ctor_element (&body, desc, *poffset,
1349 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1350 gfc_array_index_type,
1351 *poffset, gfc_index_one_node);
1355 /* Collect multiple scalar constants into a constructor. */
1356 VEC(constructor_elt,gc) *v = NULL;
1360 HOST_WIDE_INT idx = 0;
1363 /* Count the number of consecutive scalar constants. */
1364 while (p && !(p->iterator
1365 || p->expr->expr_type != EXPR_CONSTANT))
1367 gfc_init_se (&se, NULL);
1368 gfc_conv_constant (&se, p->expr);
1370 if (c->expr->ts.type != BT_CHARACTER)
1371 se.expr = fold_convert (type, se.expr);
1372 /* For constant character array constructors we build
1373 an array of pointers. */
1374 else if (POINTER_TYPE_P (type))
1375 se.expr = gfc_build_addr_expr
1376 (gfc_get_pchar_type (p->expr->ts.kind),
1379 CONSTRUCTOR_APPEND_ELT (v,
1380 build_int_cst (gfc_array_index_type,
1384 p = gfc_constructor_next (p);
1387 bound = size_int (n - 1);
1388 /* Create an array type to hold them. */
1389 tmptype = build_range_type (gfc_array_index_type,
1390 gfc_index_zero_node, bound);
1391 tmptype = build_array_type (type, tmptype);
1393 init = build_constructor (tmptype, v);
1394 TREE_CONSTANT (init) = 1;
1395 TREE_STATIC (init) = 1;
1396 /* Create a static variable to hold the data. */
1397 tmp = gfc_create_var (tmptype, "data");
1398 TREE_STATIC (tmp) = 1;
1399 TREE_CONSTANT (tmp) = 1;
1400 TREE_READONLY (tmp) = 1;
1401 DECL_INITIAL (tmp) = init;
1404 /* Use BUILTIN_MEMCPY to assign the values. */
1405 tmp = gfc_conv_descriptor_data_get (desc);
1406 tmp = build_fold_indirect_ref_loc (input_location,
1408 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1409 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1410 init = gfc_build_addr_expr (NULL_TREE, init);
1412 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1413 bound = build_int_cst (size_type_node, n * size);
1414 tmp = build_call_expr_loc (input_location,
1415 built_in_decls[BUILT_IN_MEMCPY], 3,
1417 gfc_add_expr_to_block (&body, tmp);
1419 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1420 gfc_array_index_type, *poffset,
1421 build_int_cst (gfc_array_index_type, n));
1423 if (!INTEGER_CST_P (*poffset))
1425 gfc_add_modify (&body, *offsetvar, *poffset);
1426 *poffset = *offsetvar;
1430 /* The frontend should already have done any expansions
1434 /* Pass the code as is. */
1435 tmp = gfc_finish_block (&body);
1436 gfc_add_expr_to_block (pblock, tmp);
1440 /* Build the implied do-loop. */
1441 stmtblock_t implied_do_block;
1449 loopbody = gfc_finish_block (&body);
1451 /* Create a new block that holds the implied-do loop. A temporary
1452 loop-variable is used. */
1453 gfc_start_block(&implied_do_block);
1455 /* Initialize the loop. */
1456 gfc_init_se (&se, NULL);
1457 gfc_conv_expr_val (&se, c->iterator->start);
1458 gfc_add_block_to_block (&implied_do_block, &se.pre);
1459 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1461 gfc_init_se (&se, NULL);
1462 gfc_conv_expr_val (&se, c->iterator->end);
1463 gfc_add_block_to_block (&implied_do_block, &se.pre);
1464 end = gfc_evaluate_now (se.expr, &implied_do_block);
1466 gfc_init_se (&se, NULL);
1467 gfc_conv_expr_val (&se, c->iterator->step);
1468 gfc_add_block_to_block (&implied_do_block, &se.pre);
1469 step = gfc_evaluate_now (se.expr, &implied_do_block);
1471 /* If this array expands dynamically, and the number of iterations
1472 is not constant, we won't have allocated space for the static
1473 part of C->EXPR's size. Do that now. */
1474 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1476 /* Get the number of iterations. */
1477 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1479 /* Get the static part of C->EXPR's size. */
1480 gfc_get_array_constructor_element_size (&size, c->expr);
1481 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1483 /* Grow the array by TMP * TMP2 elements. */
1484 tmp = fold_build2_loc (input_location, MULT_EXPR,
1485 gfc_array_index_type, tmp, tmp2);
1486 gfc_grow_array (&implied_do_block, desc, tmp);
1489 /* Generate the loop body. */
1490 exit_label = gfc_build_label_decl (NULL_TREE);
1491 gfc_start_block (&body);
1493 /* Generate the exit condition. Depending on the sign of
1494 the step variable we have to generate the correct
1496 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1497 step, build_int_cst (TREE_TYPE (step), 0));
1498 cond = fold_build3_loc (input_location, COND_EXPR,
1499 boolean_type_node, tmp,
1500 fold_build2_loc (input_location, GT_EXPR,
1501 boolean_type_node, shadow_loopvar, end),
1502 fold_build2_loc (input_location, LT_EXPR,
1503 boolean_type_node, shadow_loopvar, end));
1504 tmp = build1_v (GOTO_EXPR, exit_label);
1505 TREE_USED (exit_label) = 1;
1506 tmp = build3_v (COND_EXPR, cond, tmp,
1507 build_empty_stmt (input_location));
1508 gfc_add_expr_to_block (&body, tmp);
1510 /* The main loop body. */
1511 gfc_add_expr_to_block (&body, loopbody);
1513 /* Increase loop variable by step. */
1514 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1515 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1517 gfc_add_modify (&body, shadow_loopvar, tmp);
1519 /* Finish the loop. */
1520 tmp = gfc_finish_block (&body);
1521 tmp = build1_v (LOOP_EXPR, tmp);
1522 gfc_add_expr_to_block (&implied_do_block, tmp);
1524 /* Add the exit label. */
1525 tmp = build1_v (LABEL_EXPR, exit_label);
1526 gfc_add_expr_to_block (&implied_do_block, tmp);
1528 /* Finishe the implied-do loop. */
1529 tmp = gfc_finish_block(&implied_do_block);
1530 gfc_add_expr_to_block(pblock, tmp);
1532 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1539 /* A catch-all to obtain the string length for anything that is not a
1540 a substring of non-constant length, a constant, array or variable. */
1543 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1548 /* Don't bother if we already know the length is a constant. */
1549 if (*len && INTEGER_CST_P (*len))
1552 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1553 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1556 gfc_conv_const_charlen (e->ts.u.cl);
1557 *len = e->ts.u.cl->backend_decl;
1561 /* Otherwise, be brutal even if inefficient. */
1562 ss = gfc_walk_expr (e);
1563 gfc_init_se (&se, NULL);
1565 /* No function call, in case of side effects. */
1566 se.no_function_call = 1;
1567 if (ss == gfc_ss_terminator)
1568 gfc_conv_expr (&se, e);
1570 gfc_conv_expr_descriptor (&se, e, ss);
1572 /* Fix the value. */
1573 *len = gfc_evaluate_now (se.string_length, &se.pre);
1575 gfc_add_block_to_block (block, &se.pre);
1576 gfc_add_block_to_block (block, &se.post);
1578 e->ts.u.cl->backend_decl = *len;
1583 /* Figure out the string length of a variable reference expression.
1584 Used by get_array_ctor_strlen. */
1587 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1593 /* Don't bother if we already know the length is a constant. */
1594 if (*len && INTEGER_CST_P (*len))
1597 ts = &expr->symtree->n.sym->ts;
1598 for (ref = expr->ref; ref; ref = ref->next)
1603 /* Array references don't change the string length. */
1607 /* Use the length of the component. */
1608 ts = &ref->u.c.component->ts;
1612 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1613 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1615 /* Note that this might evaluate expr. */
1616 get_array_ctor_all_strlen (block, expr, len);
1619 mpz_init_set_ui (char_len, 1);
1620 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1621 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1622 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1623 *len = convert (gfc_charlen_type_node, *len);
1624 mpz_clear (char_len);
1632 *len = ts->u.cl->backend_decl;
1636 /* Figure out the string length of a character array constructor.
1637 If len is NULL, don't calculate the length; this happens for recursive calls
1638 when a sub-array-constructor is an element but not at the first position,
1639 so when we're not interested in the length.
1640 Returns TRUE if all elements are character constants. */
1643 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1650 if (gfc_constructor_first (base) == NULL)
1653 *len = build_int_cstu (gfc_charlen_type_node, 0);
1657 /* Loop over all constructor elements to find out is_const, but in len we
1658 want to store the length of the first, not the last, element. We can
1659 of course exit the loop as soon as is_const is found to be false. */
1660 for (c = gfc_constructor_first (base);
1661 c && is_const; c = gfc_constructor_next (c))
1663 switch (c->expr->expr_type)
1666 if (len && !(*len && INTEGER_CST_P (*len)))
1667 *len = build_int_cstu (gfc_charlen_type_node,
1668 c->expr->value.character.length);
1672 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1679 get_array_ctor_var_strlen (block, c->expr, len);
1685 get_array_ctor_all_strlen (block, c->expr, len);
1689 /* After the first iteration, we don't want the length modified. */
1696 /* Check whether the array constructor C consists entirely of constant
1697 elements, and if so returns the number of those elements, otherwise
1698 return zero. Note, an empty or NULL array constructor returns zero. */
1700 unsigned HOST_WIDE_INT
1701 gfc_constant_array_constructor_p (gfc_constructor_base base)
1703 unsigned HOST_WIDE_INT nelem = 0;
1705 gfc_constructor *c = gfc_constructor_first (base);
1709 || c->expr->rank > 0
1710 || c->expr->expr_type != EXPR_CONSTANT)
1712 c = gfc_constructor_next (c);
1719 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1720 and the tree type of it's elements, TYPE, return a static constant
1721 variable that is compile-time initialized. */
1724 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1726 tree tmptype, init, tmp;
1727 HOST_WIDE_INT nelem;
1732 VEC(constructor_elt,gc) *v = NULL;
1734 /* First traverse the constructor list, converting the constants
1735 to tree to build an initializer. */
1737 c = gfc_constructor_first (expr->value.constructor);
1740 gfc_init_se (&se, NULL);
1741 gfc_conv_constant (&se, c->expr);
1742 if (c->expr->ts.type != BT_CHARACTER)
1743 se.expr = fold_convert (type, se.expr);
1744 else if (POINTER_TYPE_P (type))
1745 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1747 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1749 c = gfc_constructor_next (c);
1753 /* Next determine the tree type for the array. We use the gfortran
1754 front-end's gfc_get_nodesc_array_type in order to create a suitable
1755 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1757 memset (&as, 0, sizeof (gfc_array_spec));
1759 as.rank = expr->rank;
1760 as.type = AS_EXPLICIT;
1763 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1764 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1768 for (i = 0; i < expr->rank; i++)
1770 int tmp = (int) mpz_get_si (expr->shape[i]);
1771 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1772 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1776 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1778 /* as is not needed anymore. */
1779 for (i = 0; i < as.rank + as.corank; i++)
1781 gfc_free_expr (as.lower[i]);
1782 gfc_free_expr (as.upper[i]);
1785 init = build_constructor (tmptype, v);
1787 TREE_CONSTANT (init) = 1;
1788 TREE_STATIC (init) = 1;
1790 tmp = gfc_create_var (tmptype, "A");
1791 TREE_STATIC (tmp) = 1;
1792 TREE_CONSTANT (tmp) = 1;
1793 TREE_READONLY (tmp) = 1;
1794 DECL_INITIAL (tmp) = init;
1800 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1801 This mostly initializes the scalarizer state info structure with the
1802 appropriate values to directly use the array created by the function
1803 gfc_build_constant_array_constructor. */
1806 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1807 gfc_ss * ss, tree type)
1813 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1815 info = &ss->data.info;
1817 info->descriptor = tmp;
1818 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1819 info->offset = gfc_index_zero_node;
1821 for (i = 0; i < info->dimen + info->codimen; i++)
1823 info->delta[i] = gfc_index_zero_node;
1824 info->start[i] = gfc_index_zero_node;
1825 info->end[i] = gfc_index_zero_node;
1826 info->stride[i] = gfc_index_one_node;
1830 if (info->dimen > loop->temp_dim)
1831 loop->temp_dim = info->dimen;
1834 /* Helper routine of gfc_trans_array_constructor to determine if the
1835 bounds of the loop specified by LOOP are constant and simple enough
1836 to use with gfc_trans_constant_array_constructor. Returns the
1837 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1840 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1842 tree size = gfc_index_one_node;
1846 for (i = 0; i < loop->dimen; i++)
1848 /* If the bounds aren't constant, return NULL_TREE. */
1849 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1851 if (!integer_zerop (loop->from[i]))
1853 /* Only allow nonzero "from" in one-dimensional arrays. */
1854 if (loop->dimen != 1)
1856 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1857 gfc_array_index_type,
1858 loop->to[i], loop->from[i]);
1862 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1863 tmp, gfc_index_one_node);
1864 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1872 /* Array constructors are handled by constructing a temporary, then using that
1873 within the scalarization loop. This is not optimal, but seems by far the
1877 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1879 gfc_constructor_base c;
1886 bool old_first_len, old_typespec_chararray_ctor;
1887 tree old_first_len_val;
1889 /* Save the old values for nested checking. */
1890 old_first_len = first_len;
1891 old_first_len_val = first_len_val;
1892 old_typespec_chararray_ctor = typespec_chararray_ctor;
1894 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1895 typespec was given for the array constructor. */
1896 typespec_chararray_ctor = (ss->expr->ts.u.cl
1897 && ss->expr->ts.u.cl->length_from_typespec);
1899 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1900 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1902 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1906 ss->data.info.dimen = loop->dimen;
1908 c = ss->expr->value.constructor;
1909 if (ss->expr->ts.type == BT_CHARACTER)
1913 /* get_array_ctor_strlen walks the elements of the constructor, if a
1914 typespec was given, we already know the string length and want the one
1916 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1917 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1921 const_string = false;
1922 gfc_init_se (&length_se, NULL);
1923 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1924 gfc_charlen_type_node);
1925 ss->string_length = length_se.expr;
1926 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1927 gfc_add_block_to_block (&loop->post, &length_se.post);
1930 const_string = get_array_ctor_strlen (&loop->pre, c,
1931 &ss->string_length);
1933 /* Complex character array constructors should have been taken care of
1934 and not end up here. */
1935 gcc_assert (ss->string_length);
1937 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1939 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1941 type = build_pointer_type (type);
1944 type = gfc_typenode_for_spec (&ss->expr->ts);
1946 /* See if the constructor determines the loop bounds. */
1949 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1951 /* We have a multidimensional parameter. */
1953 for (n = 0; n < ss->expr->rank; n++)
1955 loop->from[n] = gfc_index_zero_node;
1956 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1957 gfc_index_integer_kind);
1958 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1959 gfc_array_index_type,
1960 loop->to[n], gfc_index_one_node);
1964 if (loop->to[0] == NULL_TREE)
1968 /* We should have a 1-dimensional, zero-based loop. */
1969 gcc_assert (loop->dimen == 1);
1970 gcc_assert (integer_zerop (loop->from[0]));
1972 /* Split the constructor size into a static part and a dynamic part.
1973 Allocate the static size up-front and record whether the dynamic
1974 size might be nonzero. */
1976 dynamic = gfc_get_array_constructor_size (&size, c);
1977 mpz_sub_ui (size, size, 1);
1978 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1982 /* Special case constant array constructors. */
1985 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1988 tree size = constant_array_constructor_loop_size (loop);
1989 if (size && compare_tree_int (size, nelem) == 0)
1991 gfc_trans_constant_array_constructor (loop, ss, type);
1997 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2000 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
2001 type, NULL_TREE, dynamic, true, false, where);
2003 desc = ss->data.info.descriptor;
2004 offset = gfc_index_zero_node;
2005 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2006 TREE_NO_WARNING (offsetvar) = 1;
2007 TREE_USED (offsetvar) = 0;
2008 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2009 &offset, &offsetvar, dynamic);
2011 /* If the array grows dynamically, the upper bound of the loop variable
2012 is determined by the array's final upper bound. */
2015 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2016 gfc_array_index_type,
2017 offsetvar, gfc_index_one_node);
2018 tmp = gfc_evaluate_now (tmp, &loop->pre);
2019 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2020 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2021 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2026 if (TREE_USED (offsetvar))
2027 pushdecl (offsetvar);
2029 gcc_assert (INTEGER_CST_P (offset));
2032 /* Disable bound checking for now because it's probably broken. */
2033 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2040 /* Restore old values of globals. */
2041 first_len = old_first_len;
2042 first_len_val = old_first_len_val;
2043 typespec_chararray_ctor = old_typespec_chararray_ctor;
2047 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2048 called after evaluating all of INFO's vector dimensions. Go through
2049 each such vector dimension and see if we can now fill in any missing
2053 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2062 for (n = 0; n < loop->dimen + loop->codimen; n++)
2065 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2066 && loop->to[n] == NULL)
2068 /* Loop variable N indexes vector dimension DIM, and we don't
2069 yet know the upper bound of loop variable N. Set it to the
2070 difference between the vector's upper and lower bounds. */
2071 gcc_assert (loop->from[n] == gfc_index_zero_node);
2072 gcc_assert (info->subscript[dim]
2073 && info->subscript[dim]->type == GFC_SS_VECTOR);
2075 gfc_init_se (&se, NULL);
2076 desc = info->subscript[dim]->data.info.descriptor;
2077 zero = gfc_rank_cst[0];
2078 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2079 gfc_array_index_type,
2080 gfc_conv_descriptor_ubound_get (desc, zero),
2081 gfc_conv_descriptor_lbound_get (desc, zero));
2082 tmp = gfc_evaluate_now (tmp, &loop->pre);
2089 /* Add the pre and post chains for all the scalar expressions in a SS chain
2090 to loop. This is called after the loop parameters have been calculated,
2091 but before the actual scalarizing loops. */
2094 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2100 /* TODO: This can generate bad code if there are ordering dependencies,
2101 e.g., a callee allocated function and an unknown size constructor. */
2102 gcc_assert (ss != NULL);
2104 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2111 /* Scalar expression. Evaluate this now. This includes elemental
2112 dimension indices, but not array section bounds. */
2113 gfc_init_se (&se, NULL);
2114 gfc_conv_expr (&se, ss->expr);
2115 gfc_add_block_to_block (&loop->pre, &se.pre);
2117 if (ss->expr->ts.type != BT_CHARACTER)
2119 /* Move the evaluation of scalar expressions outside the
2120 scalarization loop, except for WHERE assignments. */
2122 se.expr = convert(gfc_array_index_type, se.expr);
2124 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2125 gfc_add_block_to_block (&loop->pre, &se.post);
2128 gfc_add_block_to_block (&loop->post, &se.post);
2130 ss->data.scalar.expr = se.expr;
2131 ss->string_length = se.string_length;
2134 case GFC_SS_REFERENCE:
2135 /* Scalar argument to elemental procedure. Evaluate this
2137 gfc_init_se (&se, NULL);
2138 gfc_conv_expr (&se, ss->expr);
2139 gfc_add_block_to_block (&loop->pre, &se.pre);
2140 gfc_add_block_to_block (&loop->post, &se.post);
2142 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2143 ss->string_length = se.string_length;
2146 case GFC_SS_SECTION:
2147 /* Add the expressions for scalar and vector subscripts. */
2148 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2149 if (ss->data.info.subscript[n])
2150 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2153 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2157 /* Get the vector's descriptor and store it in SS. */
2158 gfc_init_se (&se, NULL);
2159 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2160 gfc_add_block_to_block (&loop->pre, &se.pre);
2161 gfc_add_block_to_block (&loop->post, &se.post);
2162 ss->data.info.descriptor = se.expr;
2165 case GFC_SS_INTRINSIC:
2166 gfc_add_intrinsic_ss_code (loop, ss);
2169 case GFC_SS_FUNCTION:
2170 /* Array function return value. We call the function and save its
2171 result in a temporary for use inside the loop. */
2172 gfc_init_se (&se, NULL);
2175 gfc_conv_expr (&se, ss->expr);
2176 gfc_add_block_to_block (&loop->pre, &se.pre);
2177 gfc_add_block_to_block (&loop->post, &se.post);
2178 ss->string_length = se.string_length;
2181 case GFC_SS_CONSTRUCTOR:
2182 if (ss->expr->ts.type == BT_CHARACTER
2183 && ss->string_length == NULL
2184 && ss->expr->ts.u.cl
2185 && ss->expr->ts.u.cl->length)
2187 gfc_init_se (&se, NULL);
2188 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2189 gfc_charlen_type_node);
2190 ss->string_length = se.expr;
2191 gfc_add_block_to_block (&loop->pre, &se.pre);
2192 gfc_add_block_to_block (&loop->post, &se.post);
2194 gfc_trans_array_constructor (loop, ss, where);
2198 case GFC_SS_COMPONENT:
2199 /* Do nothing. These are handled elsewhere. */
2209 /* Translate expressions for the descriptor and data pointer of a SS. */
2213 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2218 /* Get the descriptor for the array to be scalarized. */
2219 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2220 gfc_init_se (&se, NULL);
2221 se.descriptor_only = 1;
2222 gfc_conv_expr_lhs (&se, ss->expr);
2223 gfc_add_block_to_block (block, &se.pre);
2224 ss->data.info.descriptor = se.expr;
2225 ss->string_length = se.string_length;
2229 /* Also the data pointer. */
2230 tmp = gfc_conv_array_data (se.expr);
2231 /* If this is a variable or address of a variable we use it directly.
2232 Otherwise we must evaluate it now to avoid breaking dependency
2233 analysis by pulling the expressions for elemental array indices
2236 || (TREE_CODE (tmp) == ADDR_EXPR
2237 && DECL_P (TREE_OPERAND (tmp, 0)))))
2238 tmp = gfc_evaluate_now (tmp, block);
2239 ss->data.info.data = tmp;
2241 tmp = gfc_conv_array_offset (se.expr);
2242 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2244 /* Make absolutely sure that the saved_offset is indeed saved
2245 so that the variable is still accessible after the loops
2247 ss->data.info.saved_offset = ss->data.info.offset;
2252 /* Initialize a gfc_loopinfo structure. */
2255 gfc_init_loopinfo (gfc_loopinfo * loop)
2259 memset (loop, 0, sizeof (gfc_loopinfo));
2260 gfc_init_block (&loop->pre);
2261 gfc_init_block (&loop->post);
2263 /* Initially scalarize in order and default to no loop reversal. */
2264 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2267 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2270 loop->ss = gfc_ss_terminator;
2274 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2278 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2284 /* Return an expression for the data pointer of an array. */
2287 gfc_conv_array_data (tree descriptor)
2291 type = TREE_TYPE (descriptor);
2292 if (GFC_ARRAY_TYPE_P (type))
2294 if (TREE_CODE (type) == POINTER_TYPE)
2298 /* Descriptorless arrays. */
2299 return gfc_build_addr_expr (NULL_TREE, descriptor);
2303 return gfc_conv_descriptor_data_get (descriptor);
2307 /* Return an expression for the base offset of an array. */
2310 gfc_conv_array_offset (tree descriptor)
2314 type = TREE_TYPE (descriptor);
2315 if (GFC_ARRAY_TYPE_P (type))
2316 return GFC_TYPE_ARRAY_OFFSET (type);
2318 return gfc_conv_descriptor_offset_get (descriptor);
2322 /* Get an expression for the array stride. */
2325 gfc_conv_array_stride (tree descriptor, int dim)
2330 type = TREE_TYPE (descriptor);
2332 /* For descriptorless arrays use the array size. */
2333 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2334 if (tmp != NULL_TREE)
2337 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2342 /* Like gfc_conv_array_stride, but for the lower bound. */
2345 gfc_conv_array_lbound (tree descriptor, int dim)
2350 type = TREE_TYPE (descriptor);
2352 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2353 if (tmp != NULL_TREE)
2356 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2361 /* Like gfc_conv_array_stride, but for the upper bound. */
2364 gfc_conv_array_ubound (tree descriptor, int dim)
2369 type = TREE_TYPE (descriptor);
2371 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2372 if (tmp != NULL_TREE)
2375 /* This should only ever happen when passing an assumed shape array
2376 as an actual parameter. The value will never be used. */
2377 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2378 return gfc_index_zero_node;
2380 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2385 /* Generate code to perform an array index bound check. */
2388 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2389 locus * where, bool check_upper)
2392 tree tmp_lo, tmp_up;
2394 const char * name = NULL;
2396 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2399 index = gfc_evaluate_now (index, &se->pre);
2401 /* We find a name for the error message. */
2403 name = se->ss->expr->symtree->name;
2405 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2406 && se->loop->ss->expr->symtree)
2407 name = se->loop->ss->expr->symtree->name;
2409 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2410 && se->loop->ss->loop_chain->expr
2411 && se->loop->ss->loop_chain->expr->symtree)
2412 name = se->loop->ss->loop_chain->expr->symtree->name;
2414 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2416 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2417 && se->loop->ss->expr->value.function.name)
2418 name = se->loop->ss->expr->value.function.name;
2420 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2421 || se->loop->ss->type == GFC_SS_SCALAR)
2422 name = "unnamed constant";
2425 if (TREE_CODE (descriptor) == VAR_DECL)
2426 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2428 /* If upper bound is present, include both bounds in the error message. */
2431 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2432 tmp_up = gfc_conv_array_ubound (descriptor, n);
2435 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2436 "outside of expected range (%%ld:%%ld)", n+1, name);
2438 asprintf (&msg, "Index '%%ld' of dimension %d "
2439 "outside of expected range (%%ld:%%ld)", n+1);
2441 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2443 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2444 fold_convert (long_integer_type_node, index),
2445 fold_convert (long_integer_type_node, tmp_lo),
2446 fold_convert (long_integer_type_node, tmp_up));
2447 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2449 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2450 fold_convert (long_integer_type_node, index),
2451 fold_convert (long_integer_type_node, tmp_lo),
2452 fold_convert (long_integer_type_node, tmp_up));
2457 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2460 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2461 "below lower bound of %%ld", n+1, name);
2463 asprintf (&msg, "Index '%%ld' of dimension %d "
2464 "below lower bound of %%ld", n+1);
2466 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2468 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2469 fold_convert (long_integer_type_node, index),
2470 fold_convert (long_integer_type_node, tmp_lo));
2478 /* Return the offset for an index. Performs bound checking for elemental
2479 dimensions. Single element references are processed separately.
2480 DIM is the array dimension, I is the loop dimension. */
2483 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2484 gfc_array_ref * ar, tree stride)
2490 /* Get the index into the array for this dimension. */
2493 gcc_assert (ar->type != AR_ELEMENT);
2494 switch (ar->dimen_type[dim])
2496 case DIMEN_THIS_IMAGE:
2500 /* Elemental dimension. */
2501 gcc_assert (info->subscript[dim]
2502 && info->subscript[dim]->type == GFC_SS_SCALAR);
2503 /* We've already translated this value outside the loop. */
2504 index = info->subscript[dim]->data.scalar.expr;
2506 index = gfc_trans_array_bound_check (se, info->descriptor,
2507 index, dim, &ar->where,
2508 ar->as->type != AS_ASSUMED_SIZE
2509 || dim < ar->dimen - 1);
2513 gcc_assert (info && se->loop);
2514 gcc_assert (info->subscript[dim]
2515 && info->subscript[dim]->type == GFC_SS_VECTOR);
2516 desc = info->subscript[dim]->data.info.descriptor;
2518 /* Get a zero-based index into the vector. */
2519 index = fold_build2_loc (input_location, MINUS_EXPR,
2520 gfc_array_index_type,
2521 se->loop->loopvar[i], se->loop->from[i]);
2523 /* Multiply the index by the stride. */
2524 index = fold_build2_loc (input_location, MULT_EXPR,
2525 gfc_array_index_type,
2526 index, gfc_conv_array_stride (desc, 0));
2528 /* Read the vector to get an index into info->descriptor. */
2529 data = build_fold_indirect_ref_loc (input_location,
2530 gfc_conv_array_data (desc));
2531 index = gfc_build_array_ref (data, index, NULL);
2532 index = gfc_evaluate_now (index, &se->pre);
2533 index = fold_convert (gfc_array_index_type, index);
2535 /* Do any bounds checking on the final info->descriptor index. */
2536 index = gfc_trans_array_bound_check (se, info->descriptor,
2537 index, dim, &ar->where,
2538 ar->as->type != AS_ASSUMED_SIZE
2539 || dim < ar->dimen - 1);
2543 /* Scalarized dimension. */
2544 gcc_assert (info && se->loop);
2546 /* Multiply the loop variable by the stride and delta. */
2547 index = se->loop->loopvar[i];
2548 if (!integer_onep (info->stride[dim]))
2549 index = fold_build2_loc (input_location, MULT_EXPR,
2550 gfc_array_index_type, index,
2552 if (!integer_zerop (info->delta[dim]))
2553 index = fold_build2_loc (input_location, PLUS_EXPR,
2554 gfc_array_index_type, index,
2564 /* Temporary array or derived type component. */
2565 gcc_assert (se->loop);
2566 index = se->loop->loopvar[se->loop->order[i]];
2567 if (!integer_zerop (info->delta[dim]))
2568 index = fold_build2_loc (input_location, PLUS_EXPR,
2569 gfc_array_index_type, index, info->delta[dim]);
2572 /* Multiply by the stride. */
2573 if (!integer_onep (stride))
2574 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2581 /* Build a scalarized reference to an array. */
2584 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2587 tree decl = NULL_TREE;
2592 info = &se->ss->data.info;
2594 n = se->loop->order[0];
2598 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2600 /* Add the offset for this dimension to the stored offset for all other
2602 if (!integer_zerop (info->offset))
2603 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2604 index, info->offset);
2606 if (se->ss->expr && is_subref_array (se->ss->expr))
2607 decl = se->ss->expr->symtree->n.sym->backend_decl;
2609 tmp = build_fold_indirect_ref_loc (input_location,
2611 se->expr = gfc_build_array_ref (tmp, index, decl);
2615 /* Translate access of temporary array. */
2618 gfc_conv_tmp_array_ref (gfc_se * se)
2620 se->string_length = se->ss->string_length;
2621 gfc_conv_scalarized_array_ref (se, NULL);
2622 gfc_advance_se_ss_chain (se);
2625 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2628 add_to_offset (tree *cst_offset, tree *offset, tree t)
2630 if (TREE_CODE (t) == INTEGER_CST)
2631 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2634 if (!integer_zerop (*offset))
2635 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2636 gfc_array_index_type, *offset, t);
2642 /* Build an array reference. se->expr already holds the array descriptor.
2643 This should be either a variable, indirect variable reference or component
2644 reference. For arrays which do not have a descriptor, se->expr will be
2646 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2649 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2653 tree offset, cst_offset;
2661 gcc_assert (ar->codimen);
2663 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2664 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2667 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2668 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2669 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2671 /* Use the actual tree type and not the wrapped coarray. */
2672 if (!se->want_pointer)
2673 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2680 /* Handle scalarized references separately. */
2681 if (ar->type != AR_ELEMENT)
2683 gfc_conv_scalarized_array_ref (se, ar);
2684 gfc_advance_se_ss_chain (se);
2688 cst_offset = offset = gfc_index_zero_node;
2689 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2691 /* Calculate the offsets from all the dimensions. Make sure to associate
2692 the final offset so that we form a chain of loop invariant summands. */
2693 for (n = ar->dimen - 1; n >= 0; n--)
2695 /* Calculate the index for this dimension. */
2696 gfc_init_se (&indexse, se);
2697 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2698 gfc_add_block_to_block (&se->pre, &indexse.pre);
2700 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2702 /* Check array bounds. */
2706 /* Evaluate the indexse.expr only once. */
2707 indexse.expr = save_expr (indexse.expr);
2710 tmp = gfc_conv_array_lbound (se->expr, n);
2711 if (sym->attr.temporary)
2713 gfc_init_se (&tmpse, se);
2714 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2715 gfc_array_index_type);
2716 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2720 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2722 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2723 "below lower bound of %%ld", n+1, sym->name);
2724 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2725 fold_convert (long_integer_type_node,
2727 fold_convert (long_integer_type_node, tmp));
2730 /* Upper bound, but not for the last dimension of assumed-size
2732 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2734 tmp = gfc_conv_array_ubound (se->expr, n);
2735 if (sym->attr.temporary)
2737 gfc_init_se (&tmpse, se);
2738 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2739 gfc_array_index_type);
2740 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2744 cond = fold_build2_loc (input_location, GT_EXPR,
2745 boolean_type_node, indexse.expr, tmp);
2746 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2747 "above upper bound of %%ld", n+1, sym->name);
2748 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2749 fold_convert (long_integer_type_node,
2751 fold_convert (long_integer_type_node, tmp));
2756 /* Multiply the index by the stride. */
2757 stride = gfc_conv_array_stride (se->expr, n);
2758 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2759 indexse.expr, stride);
2761 /* And add it to the total. */
2762 add_to_offset (&cst_offset, &offset, tmp);
2765 if (!integer_zerop (cst_offset))
2766 offset = fold_build2_loc (input_location, PLUS_EXPR,
2767 gfc_array_index_type, offset, cst_offset);
2769 /* Access the calculated element. */
2770 tmp = gfc_conv_array_data (se->expr);
2771 tmp = build_fold_indirect_ref (tmp);
2772 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2776 /* Generate the code to be executed immediately before entering a
2777 scalarization loop. */
2780 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2781 stmtblock_t * pblock)
2790 /* This code will be executed before entering the scalarization loop
2791 for this dimension. */
2792 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2794 if ((ss->useflags & flag) == 0)
2797 if (ss->type != GFC_SS_SECTION
2798 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2799 && ss->type != GFC_SS_COMPONENT)
2802 info = &ss->data.info;
2804 if (dim >= info->dimen)
2807 if (dim == info->dimen - 1)
2809 /* For the outermost loop calculate the offset due to any
2810 elemental dimensions. It will have been initialized with the
2811 base offset of the array. */
2814 for (i = 0; i < info->ref->u.ar.dimen; i++)
2816 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2819 gfc_init_se (&se, NULL);
2821 se.expr = info->descriptor;
2822 stride = gfc_conv_array_stride (info->descriptor, i);
2823 index = gfc_conv_array_index_offset (&se, info, i, -1,
2826 gfc_add_block_to_block (pblock, &se.pre);
2828 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2829 gfc_array_index_type,
2830 info->offset, index);
2831 info->offset = gfc_evaluate_now (info->offset, pblock);
2836 /* For the time being, the innermost loop is unconditionally on
2837 the first dimension of the scalarization loop. */
2838 gcc_assert (i == 0);
2839 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2841 /* Calculate the stride of the innermost loop. Hopefully this will
2842 allow the backend optimizers to do their stuff more effectively.
2844 info->stride0 = gfc_evaluate_now (stride, pblock);
2848 /* Add the offset for the previous loop dimension. */
2853 ar = &info->ref->u.ar;
2854 i = loop->order[dim + 1];
2862 gfc_init_se (&se, NULL);
2864 se.expr = info->descriptor;
2865 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2866 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2868 gfc_add_block_to_block (pblock, &se.pre);
2869 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2870 gfc_array_index_type, info->offset,
2872 info->offset = gfc_evaluate_now (info->offset, pblock);
2875 /* Remember this offset for the second loop. */
2876 if (dim == loop->temp_dim - 1)
2877 info->saved_offset = info->offset;
2882 /* Start a scalarized expression. Creates a scope and declares loop
2886 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2892 gcc_assert (!loop->array_parameter);
2894 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2896 n = loop->order[dim];
2898 gfc_start_block (&loop->code[n]);
2900 /* Create the loop variable. */
2901 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2903 if (dim < loop->temp_dim)
2907 /* Calculate values that will be constant within this loop. */
2908 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2910 gfc_start_block (pbody);
2914 /* Generates the actual loop code for a scalarization loop. */
2917 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2918 stmtblock_t * pbody)
2929 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2930 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2931 && n == loop->dimen - 1)
2933 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2934 init = make_tree_vec (1);
2935 cond = make_tree_vec (1);
2936 incr = make_tree_vec (1);
2938 /* Cycle statement is implemented with a goto. Exit statement must not
2939 be present for this loop. */
2940 exit_label = gfc_build_label_decl (NULL_TREE);
2941 TREE_USED (exit_label) = 1;
2943 /* Label for cycle statements (if needed). */
2944 tmp = build1_v (LABEL_EXPR, exit_label);
2945 gfc_add_expr_to_block (pbody, tmp);
2947 stmt = make_node (OMP_FOR);
2949 TREE_TYPE (stmt) = void_type_node;
2950 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2952 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2953 OMP_CLAUSE_SCHEDULE);
2954 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2955 = OMP_CLAUSE_SCHEDULE_STATIC;
2956 if (ompws_flags & OMPWS_NOWAIT)
2957 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2958 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2960 /* Initialize the loopvar. */
2961 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2963 OMP_FOR_INIT (stmt) = init;
2964 /* The exit condition. */
2965 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2967 loop->loopvar[n], loop->to[n]);
2968 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2969 OMP_FOR_COND (stmt) = cond;
2970 /* Increment the loopvar. */
2971 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2972 loop->loopvar[n], gfc_index_one_node);
2973 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2974 void_type_node, loop->loopvar[n], tmp);
2975 OMP_FOR_INCR (stmt) = incr;
2977 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2978 gfc_add_expr_to_block (&loop->code[n], stmt);
2982 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2983 && (loop->temp_ss == NULL);
2985 loopbody = gfc_finish_block (pbody);
2989 tmp = loop->from[n];
2990 loop->from[n] = loop->to[n];
2994 /* Initialize the loopvar. */
2995 if (loop->loopvar[n] != loop->from[n])
2996 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2998 exit_label = gfc_build_label_decl (NULL_TREE);
3000 /* Generate the loop body. */
3001 gfc_init_block (&block);
3003 /* The exit condition. */
3004 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3005 boolean_type_node, loop->loopvar[n], loop->to[n]);
3006 tmp = build1_v (GOTO_EXPR, exit_label);
3007 TREE_USED (exit_label) = 1;
3008 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3009 gfc_add_expr_to_block (&block, tmp);
3011 /* The main body. */
3012 gfc_add_expr_to_block (&block, loopbody);
3014 /* Increment the loopvar. */
3015 tmp = fold_build2_loc (input_location,
3016 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3017 gfc_array_index_type, loop->loopvar[n],
3018 gfc_index_one_node);
3020 gfc_add_modify (&block, loop->loopvar[n], tmp);
3022 /* Build the loop. */
3023 tmp = gfc_finish_block (&block);
3024 tmp = build1_v (LOOP_EXPR, tmp);
3025 gfc_add_expr_to_block (&loop->code[n], tmp);
3027 /* Add the exit label. */
3028 tmp = build1_v (LABEL_EXPR, exit_label);
3029 gfc_add_expr_to_block (&loop->code[n], tmp);
3035 /* Finishes and generates the loops for a scalarized expression. */
3038 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3043 stmtblock_t *pblock;
3047 /* Generate the loops. */
3048 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
3050 n = loop->order[dim];
3051 gfc_trans_scalarized_loop_end (loop, n, pblock);
3052 loop->loopvar[n] = NULL_TREE;
3053 pblock = &loop->code[n];
3056 tmp = gfc_finish_block (pblock);
3057 gfc_add_expr_to_block (&loop->pre, tmp);
3059 /* Clear all the used flags. */
3060 for (ss = loop->ss; ss; ss = ss->loop_chain)
3065 /* Finish the main body of a scalarized expression, and start the secondary
3069 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3073 stmtblock_t *pblock;
3077 /* We finish as many loops as are used by the temporary. */
3078 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3080 n = loop->order[dim];
3081 gfc_trans_scalarized_loop_end (loop, n, pblock);
3082 loop->loopvar[n] = NULL_TREE;
3083 pblock = &loop->code[n];
3086 /* We don't want to finish the outermost loop entirely. */
3087 n = loop->order[loop->temp_dim - 1];
3088 gfc_trans_scalarized_loop_end (loop, n, pblock);
3090 /* Restore the initial offsets. */
3091 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3093 if ((ss->useflags & 2) == 0)
3096 if (ss->type != GFC_SS_SECTION
3097 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3098 && ss->type != GFC_SS_COMPONENT)
3101 ss->data.info.offset = ss->data.info.saved_offset;
3104 /* Restart all the inner loops we just finished. */
3105 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3107 n = loop->order[dim];
3109 gfc_start_block (&loop->code[n]);
3111 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3113 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3116 /* Start a block for the secondary copying code. */
3117 gfc_start_block (body);
3121 /* Calculate the lower bound of an array section. */
3124 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3125 bool coarray, bool coarray_last)
3129 gfc_expr *stride = NULL;
3134 gcc_assert (ss->type == GFC_SS_SECTION);
3136 info = &ss->data.info;
3138 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3140 /* We use a zero-based index to access the vector. */
3141 info->start[dim] = gfc_index_zero_node;
3142 info->end[dim] = NULL;
3144 info->stride[dim] = gfc_index_one_node;
3148 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3149 desc = info->descriptor;
3150 start = info->ref->u.ar.start[dim];
3151 end = info->ref->u.ar.end[dim];
3153 stride = info->ref->u.ar.stride[dim];
3155 /* Calculate the start of the range. For vector subscripts this will
3156 be the range of the vector. */
3159 /* Specified section start. */
3160 gfc_init_se (&se, NULL);
3161 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3162 gfc_add_block_to_block (&loop->pre, &se.pre);
3163 info->start[dim] = se.expr;
3167 /* No lower bound specified so use the bound of the array. */
3168 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3170 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3172 /* Similarly calculate the end. Although this is not used in the
3173 scalarizer, it is needed when checking bounds and where the end
3174 is an expression with side-effects. */
3179 /* Specified section start. */
3180 gfc_init_se (&se, NULL);
3181 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3182 gfc_add_block_to_block (&loop->pre, &se.pre);
3183 info->end[dim] = se.expr;
3187 /* No upper bound specified so use the bound of the array. */
3188 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3190 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3193 /* Calculate the stride. */
3194 if (!coarray && stride == NULL)
3195 info->stride[dim] = gfc_index_one_node;
3198 gfc_init_se (&se, NULL);
3199 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3200 gfc_add_block_to_block (&loop->pre, &se.pre);
3201 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3206 /* Calculates the range start and stride for a SS chain. Also gets the
3207 descriptor and data pointer. The range of vector subscripts is the size
3208 of the vector. Array bounds are also checked. */
3211 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3219 /* Determine the rank of the loop. */
3221 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3225 case GFC_SS_SECTION:
3226 case GFC_SS_CONSTRUCTOR:
3227 case GFC_SS_FUNCTION:
3228 case GFC_SS_COMPONENT:
3229 loop->dimen = ss->data.info.dimen;
3230 loop->codimen = ss->data.info.codimen;
3233 /* As usual, lbound and ubound are exceptions!. */
3234 case GFC_SS_INTRINSIC:
3235 switch (ss->expr->value.function.isym->id)
3237 case GFC_ISYM_LBOUND:
3238 case GFC_ISYM_UBOUND:
3239 loop->dimen = ss->data.info.dimen;
3243 case GFC_ISYM_LCOBOUND:
3244 case GFC_ISYM_UCOBOUND:
3245 case GFC_ISYM_THIS_IMAGE:
3246 loop->dimen = ss->data.info.dimen;
3247 loop->codimen = ss->data.info.codimen;
3259 /* We should have determined the rank of the expression by now. If
3260 not, that's bad news. */
3261 gcc_assert (loop->dimen + loop->codimen != 0);
3263 /* Loop over all the SS in the chain. */
3264 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3266 if (ss->expr && ss->expr->shape && !ss->shape)
3267 ss->shape = ss->expr->shape;
3271 case GFC_SS_SECTION:
3272 /* Get the descriptor for the array. */
3273 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3275 for (n = 0; n < ss->data.info.dimen; n++)
3276 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3278 for (n = ss->data.info.dimen;
3279 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3280 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3281 n == ss->data.info.dimen
3282 + ss->data.info.codimen -1);
3286 case GFC_SS_INTRINSIC:
3287 switch (ss->expr->value.function.isym->id)
3289 /* Fall through to supply start and stride. */
3290 case GFC_ISYM_LBOUND:
3291 case GFC_ISYM_UBOUND:
3292 case GFC_ISYM_LCOBOUND:
3293 case GFC_ISYM_UCOBOUND:
3294 case GFC_ISYM_THIS_IMAGE:
3301 case GFC_SS_CONSTRUCTOR:
3302 case GFC_SS_FUNCTION:
3303 for (n = 0; n < ss->data.info.dimen; n++)
3305 ss->data.info.start[n] = gfc_index_zero_node;
3306 ss->data.info.end[n] = gfc_index_zero_node;
3307 ss->data.info.stride[n] = gfc_index_one_node;
3316 /* The rest is just runtime bound checking. */
3317 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3320 tree lbound, ubound;
3322 tree size[GFC_MAX_DIMENSIONS];
3323 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3328 gfc_start_block (&block);
3330 for (n = 0; n < loop->dimen; n++)
3331 size[n] = NULL_TREE;
3333 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3337 if (ss->type != GFC_SS_SECTION)
3340 /* Catch allocatable lhs in f2003. */
3341 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3344 gfc_start_block (&inner);
3346 /* TODO: range checking for mapped dimensions. */
3347 info = &ss->data.info;
3349 /* This code only checks ranges. Elemental and vector
3350 dimensions are checked later. */
3351 for (n = 0; n < loop->dimen; n++)
3356 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3359 if (dim == info->ref->u.ar.dimen - 1
3360 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3361 check_upper = false;
3365 /* Zero stride is not allowed. */
3366 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3367 info->stride[dim], gfc_index_zero_node);
3368 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3369 "of array '%s'", dim + 1, ss->expr->symtree->name);
3370 gfc_trans_runtime_check (true, false, tmp, &inner,
3371 &ss->expr->where, msg);
3374 desc = ss->data.info.descriptor;
3376 /* This is the run-time equivalent of resolve.c's
3377 check_dimension(). The logical is more readable there
3378 than it is here, with all the trees. */
3379 lbound = gfc_conv_array_lbound (desc, dim);
3380 end = info->end[dim];
3382 ubound = gfc_conv_array_ubound (desc, dim);
3386 /* non_zerosized is true when the selected range is not
3388 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3389 boolean_type_node, info->stride[dim],
3390 gfc_index_zero_node);
3391 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3392 info->start[dim], end);
3393 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3394 boolean_type_node, stride_pos, tmp);
3396 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3398 info->stride[dim], gfc_index_zero_node);
3399 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3400 info->start[dim], end);
3401 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3404 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3406 stride_pos, stride_neg);
3408 /* Check the start of the range against the lower and upper
3409 bounds of the array, if the range is not empty.
3410 If upper bound is present, include both bounds in the
3414 tmp = fold_build2_loc (input_location, LT_EXPR,
3416 info->start[dim], lbound);
3417 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3419 non_zerosized, tmp);
3420 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3422 info->start[dim], ubound);
3423 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3425 non_zerosized, tmp2);
3426 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3427 "outside of expected range (%%ld:%%ld)",
3428 dim + 1, ss->expr->symtree->name);
3429 gfc_trans_runtime_check (true, false, tmp, &inner,
3430 &ss->expr->where, msg,
3431 fold_convert (long_integer_type_node, info->start[dim]),
3432 fold_convert (long_integer_type_node, lbound),
3433 fold_convert (long_integer_type_node, ubound));
3434 gfc_trans_runtime_check (true, false, tmp2, &inner,
3435 &ss->expr->where, msg,
3436 fold_convert (long_integer_type_node, info->start[dim]),
3437 fold_convert (long_integer_type_node, lbound),
3438 fold_convert (long_integer_type_node, ubound));
3443 tmp = fold_build2_loc (input_location, LT_EXPR,
3445 info->start[dim], lbound);
3446 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3447 boolean_type_node, non_zerosized, tmp);
3448 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3449 "below lower bound of %%ld",
3450 dim + 1, ss->expr->symtree->name);
3451 gfc_trans_runtime_check (true, false, tmp, &inner,
3452 &ss->expr->where, msg,
3453 fold_convert (long_integer_type_node, info->start[dim]),
3454 fold_convert (long_integer_type_node, lbound));
3458 /* Compute the last element of the range, which is not
3459 necessarily "end" (think 0:5:3, which doesn't contain 5)
3460 and check it against both lower and upper bounds. */
3462 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3463 gfc_array_index_type, end,
3465 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3466 gfc_array_index_type, tmp,
3468 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3469 gfc_array_index_type, end, tmp);
3470 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3471 boolean_type_node, tmp, lbound);
3472 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3473 boolean_type_node, non_zerosized, tmp2);
3476 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3477 boolean_type_node, tmp, ubound);
3478 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3479 boolean_type_node, non_zerosized, tmp3);
3480 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3481 "outside of expected range (%%ld:%%ld)",
3482 dim + 1, ss->expr->symtree->name);
3483 gfc_trans_runtime_check (true, false, tmp2, &inner,
3484 &ss->expr->where, msg,
3485 fold_convert (long_integer_type_node, tmp),
3486 fold_convert (long_integer_type_node, ubound),
3487 fold_convert (long_integer_type_node, lbound));
3488 gfc_trans_runtime_check (true, false, tmp3, &inner,
3489 &ss->expr->where, msg,
3490 fold_convert (long_integer_type_node, tmp),
3491 fold_convert (long_integer_type_node, ubound),
3492 fold_convert (long_integer_type_node, lbound));
3497 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3498 "below lower bound of %%ld",
3499 dim + 1, ss->expr->symtree->name);
3500 gfc_trans_runtime_check (true, false, tmp2, &inner,
3501 &ss->expr->where, msg,
3502 fold_convert (long_integer_type_node, tmp),
3503 fold_convert (long_integer_type_node, lbound));
3507 /* Check the section sizes match. */
3508 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3509 gfc_array_index_type, end,
3511 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3512 gfc_array_index_type, tmp,
3514 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3515 gfc_array_index_type,
3516 gfc_index_one_node, tmp);
3517 tmp = fold_build2_loc (input_location, MAX_EXPR,
3518 gfc_array_index_type, tmp,
3519 build_int_cst (gfc_array_index_type, 0));
3520 /* We remember the size of the first section, and check all the
3521 others against this. */
3524 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3525 boolean_type_node, tmp, size[n]);
3526 asprintf (&msg, "Array bound mismatch for dimension %d "
3527 "of array '%s' (%%ld/%%ld)",
3528 dim + 1, ss->expr->symtree->name);
3530 gfc_trans_runtime_check (true, false, tmp3, &inner,
3531 &ss->expr->where, msg,
3532 fold_convert (long_integer_type_node, tmp),
3533 fold_convert (long_integer_type_node, size[n]));
3538 size[n] = gfc_evaluate_now (tmp, &inner);
3541 tmp = gfc_finish_block (&inner);
3543 /* For optional arguments, only check bounds if the argument is
3545 if (ss->expr->symtree->n.sym->attr.optional
3546 || ss->expr->symtree->n.sym->attr.not_always_present)
3547 tmp = build3_v (COND_EXPR,
3548 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3549 tmp, build_empty_stmt (input_location));
3551 gfc_add_expr_to_block (&block, tmp);
3555 tmp = gfc_finish_block (&block);
3556 gfc_add_expr_to_block (&loop->pre, tmp);
3560 /* Return true if both symbols could refer to the same data object. Does
3561 not take account of aliasing due to equivalence statements. */
3564 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3565 bool lsym_target, bool rsym_pointer, bool rsym_target)
3567 /* Aliasing isn't possible if the symbols have different base types. */
3568 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3571 /* Pointers can point to other pointers and target objects. */
3573 if ((lsym_pointer && (rsym_pointer || rsym_target))
3574 || (rsym_pointer && (lsym_pointer || lsym_target)))
3577 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3578 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3580 if (lsym_target && rsym_target
3581 && ((lsym->attr.dummy && !lsym->attr.contiguous
3582 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3583 || (rsym->attr.dummy && !rsym->attr.contiguous
3584 && (!rsym->attr.dimension
3585 || rsym->as->type == AS_ASSUMED_SHAPE))))
3592 /* Return true if the two SS could be aliased, i.e. both point to the same data
3594 /* TODO: resolve aliases based on frontend expressions. */
3597 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3603 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3605 lsym = lss->expr->symtree->n.sym;
3606 rsym = rss->expr->symtree->n.sym;
3608 lsym_pointer = lsym->attr.pointer;
3609 lsym_target = lsym->attr.target;
3610 rsym_pointer = rsym->attr.pointer;
3611 rsym_target = rsym->attr.target;
3613 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3614 rsym_pointer, rsym_target))
3617 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3618 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3621 /* For derived types we must check all the component types. We can ignore
3622 array references as these will have the same base type as the previous
3624 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3626 if (lref->type != REF_COMPONENT)
3629 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3630 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3632 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3633 rsym_pointer, rsym_target))
3636 if ((lsym_pointer && (rsym_pointer || rsym_target))
3637 || (rsym_pointer && (lsym_pointer || lsym_target)))
3639 if (gfc_compare_types (&lref->u.c.component->ts,
3644 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3647 if (rref->type != REF_COMPONENT)
3650 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3651 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3653 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3654 lsym_pointer, lsym_target,
3655 rsym_pointer, rsym_target))
3658 if ((lsym_pointer && (rsym_pointer || rsym_target))
3659 || (rsym_pointer && (lsym_pointer || lsym_target)))
3661 if (gfc_compare_types (&lref->u.c.component->ts,
3662 &rref->u.c.sym->ts))
3664 if (gfc_compare_types (&lref->u.c.sym->ts,
3665 &rref->u.c.component->ts))
3667 if (gfc_compare_types (&lref->u.c.component->ts,
3668 &rref->u.c.component->ts))
3674 lsym_pointer = lsym->attr.pointer;
3675 lsym_target = lsym->attr.target;
3676 lsym_pointer = lsym->attr.pointer;
3677 lsym_target = lsym->attr.target;
3679 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3681 if (rref->type != REF_COMPONENT)
3684 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3685 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3687 if (symbols_could_alias (rref->u.c.sym, lsym,
3688 lsym_pointer, lsym_target,
3689 rsym_pointer, rsym_target))
3692 if ((lsym_pointer && (rsym_pointer || rsym_target))
3693 || (rsym_pointer && (lsym_pointer || lsym_target)))
3695 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3704 /* Resolve array data dependencies. Creates a temporary if required. */
3705 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3709 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3718 loop->temp_ss = NULL;
3720 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3722 if (ss->type != GFC_SS_SECTION)
3725 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3727 if (gfc_could_be_alias (dest, ss)
3728 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3736 lref = dest->expr->ref;
3737 rref = ss->expr->ref;
3739 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3744 for (i = 0; i < dest->data.info.dimen; i++)
3745 for (j = 0; j < ss->data.info.dimen; j++)
3747 && dest->data.info.dim[i] == ss->data.info.dim[j])
3749 /* If we don't access array elements in the same order,
3750 there is a dependency. */
3755 /* TODO : loop shifting. */
3758 /* Mark the dimensions for LOOP SHIFTING */
3759 for (n = 0; n < loop->dimen; n++)
3761 int dim = dest->data.info.dim[n];
3763 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3765 else if (! gfc_is_same_range (&lref->u.ar,
3766 &rref->u.ar, dim, 0))
3770 /* Put all the dimensions with dependencies in the
3773 for (n = 0; n < loop->dimen; n++)
3775 gcc_assert (loop->order[n] == n);
3777 loop->order[dim++] = n;
3779 for (n = 0; n < loop->dimen; n++)
3782 loop->order[dim++] = n;
3785 gcc_assert (dim == loop->dimen);
3796 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3797 if (GFC_ARRAY_TYPE_P (base_type)
3798 || GFC_DESCRIPTOR_TYPE_P (base_type))
3799 base_type = gfc_get_element_type (base_type);
3800 loop->temp_ss = gfc_get_ss ();
3801 loop->temp_ss->type = GFC_SS_TEMP;
3802 loop->temp_ss->data.temp.type = base_type;
3803 loop->temp_ss->string_length = dest->string_length;
3804 loop->temp_ss->data.temp.dimen = loop->dimen;
3805 loop->temp_ss->data.temp.codimen = loop->codimen;
3806 loop->temp_ss->next = gfc_ss_terminator;
3807 gfc_add_ss_to_loop (loop, loop->temp_ss);
3810 loop->temp_ss = NULL;
3814 /* Initialize the scalarization loop. Creates the loop variables. Determines
3815 the range of the loop variables. Creates a temporary if required.
3816 Calculates how to transform from loop variables to array indices for each
3817 expression. Also generates code for scalar expressions which have been
3818 moved outside the loop. */
3821 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3823 int n, dim, spec_dim;
3825 gfc_ss_info *specinfo;
3828 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3829 bool dynamic[GFC_MAX_DIMENSIONS];
3834 for (n = 0; n < loop->dimen + loop->codimen; n++)
3838 /* We use one SS term, and use that to determine the bounds of the
3839 loop for this dimension. We try to pick the simplest term. */
3840 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3842 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3845 info = &ss->data.info;
3848 if (loopspec[n] != NULL)
3850 specinfo = &loopspec[n]->data.info;
3851 spec_dim = specinfo->dim[n];
3855 /* Silence unitialized warnings. */
3862 gcc_assert (ss->shape[dim]);
3863 /* The frontend has worked out the size for us. */
3865 || !loopspec[n]->shape
3866 || !integer_zerop (specinfo->start[spec_dim]))
3867 /* Prefer zero-based descriptors if possible. */
3872 if (ss->type == GFC_SS_CONSTRUCTOR)
3874 gfc_constructor_base base;
3875 /* An unknown size constructor will always be rank one.
3876 Higher rank constructors will either have known shape,
3877 or still be wrapped in a call to reshape. */
3878 gcc_assert (loop->dimen == 1);
3880 /* Always prefer to use the constructor bounds if the size
3881 can be determined at compile time. Prefer not to otherwise,
3882 since the general case involves realloc, and it's better to
3883 avoid that overhead if possible. */
3884 base = ss->expr->value.constructor;
3885 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3886 if (!dynamic[n] || !loopspec[n])
3891 /* TODO: Pick the best bound if we have a choice between a
3892 function and something else. */
3893 if (ss->type == GFC_SS_FUNCTION)
3899 /* Avoid using an allocatable lhs in an assignment, since
3900 there might be a reallocation coming. */
3901 if (loopspec[n] && ss->is_alloc_lhs)
3904 if (ss->type != GFC_SS_SECTION)
3909 /* Criteria for choosing a loop specifier (most important first):
3910 doesn't need realloc
3916 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3917 || n >= loop->dimen)
3919 else if (integer_onep (info->stride[dim])
3920 && !integer_onep (specinfo->stride[spec_dim]))
3922 else if (INTEGER_CST_P (info->stride[dim])
3923 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3925 else if (INTEGER_CST_P (info->start[dim])
3926 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3928 /* We don't work out the upper bound.
3929 else if (INTEGER_CST_P (info->finish[n])
3930 && ! INTEGER_CST_P (specinfo->finish[n]))
3931 loopspec[n] = ss; */
3934 /* We should have found the scalarization loop specifier. If not,
3936 gcc_assert (loopspec[n]);
3938 info = &loopspec[n]->data.info;
3941 /* Set the extents of this range. */
3942 cshape = loopspec[n]->shape;
3943 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3944 && INTEGER_CST_P (info->stride[dim]))
3946 loop->from[n] = info->start[dim];
3947 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3948 mpz_sub_ui (i, i, 1);
3949 /* To = from + (size - 1) * stride. */
3950 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3951 if (!integer_onep (info->stride[dim]))
3952 tmp = fold_build2_loc (input_location, MULT_EXPR,
3953 gfc_array_index_type, tmp,
3955 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3956 gfc_array_index_type,
3957 loop->from[n], tmp);
3961 loop->from[n] = info->start[dim];
3962 switch (loopspec[n]->type)
3964 case GFC_SS_CONSTRUCTOR:
3965 /* The upper bound is calculated when we expand the
3967 gcc_assert (loop->to[n] == NULL_TREE);
3970 case GFC_SS_SECTION:
3971 /* Use the end expression if it exists and is not constant,
3972 so that it is only evaluated once. */
3973 loop->to[n] = info->end[dim];
3976 case GFC_SS_FUNCTION:
3977 /* The loop bound will be set when we generate the call. */
3978 gcc_assert (loop->to[n] == NULL_TREE);
3986 /* Transform everything so we have a simple incrementing variable. */
3987 if (n < loop->dimen && integer_onep (info->stride[dim]))
3988 info->delta[dim] = gfc_index_zero_node;
3989 else if (n < loop->dimen)
3991 /* Set the delta for this section. */
3992 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3993 /* Number of iterations is (end - start + step) / step.
3994 with start = 0, this simplifies to
3996 for (i = 0; i<=last; i++){...}; */
3997 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3998 gfc_array_index_type, loop->to[n],
4000 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4001 gfc_array_index_type, tmp, info->stride[dim]);
4002 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4003 tmp, build_int_cst (gfc_array_index_type, -1));
4004 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4005 /* Make the loop variable start at 0. */
4006 loop->from[n] = gfc_index_zero_node;
4010 /* Add all the scalar code that can be taken out of the loops.
4011 This may include calculating the loop bounds, so do it before
4012 allocating the temporary. */
4013 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4015 /* If we want a temporary then create it. */
4016 if (loop->temp_ss != NULL)
4018 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
4020 /* Make absolutely sure that this is a complete type. */
4021 if (loop->temp_ss->string_length)
4022 loop->temp_ss->data.temp.type
4023 = gfc_get_character_type_len_for_eltype
4024 (TREE_TYPE (loop->temp_ss->data.temp.type),
4025 loop->temp_ss->string_length);
4027 tmp = loop->temp_ss->data.temp.type;
4028 n = loop->temp_ss->data.temp.dimen;
4029 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
4030 loop->temp_ss->type = GFC_SS_SECTION;
4031 loop->temp_ss->data.info.dimen = n;
4033 gcc_assert (loop->temp_ss->data.info.dimen != 0);
4034 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
4035 loop->temp_ss->data.info.dim[n] = n;
4037 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4038 &loop->temp_ss->data.info, tmp, NULL_TREE,
4039 false, true, false, where);
4042 for (n = 0; n < loop->temp_dim; n++)
4043 loopspec[loop->order[n]] = NULL;
4047 /* For array parameters we don't have loop variables, so don't calculate the
4049 if (loop->array_parameter)
4052 /* Calculate the translation from loop variables to array indices. */
4053 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4055 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4056 && ss->type != GFC_SS_CONSTRUCTOR)
4060 info = &ss->data.info;
4062 for (n = 0; n < info->dimen; n++)
4064 /* If we are specifying the range the delta is already set. */
4065 if (loopspec[n] != ss)
4067 dim = ss->data.info.dim[n];
4069 /* Calculate the offset relative to the loop variable.
4070 First multiply by the stride. */
4071 tmp = loop->from[n];
4072 if (!integer_onep (info->stride[dim]))
4073 tmp = fold_build2_loc (input_location, MULT_EXPR,
4074 gfc_array_index_type,
4075 tmp, info->stride[dim]);
4077 /* Then subtract this from our starting value. */
4078 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4079 gfc_array_index_type,
4080 info->start[dim], tmp);
4082 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4089 /* Calculate the size of a given array dimension from the bounds. This
4090 is simply (ubound - lbound + 1) if this expression is positive
4091 or 0 if it is negative (pick either one if it is zero). Optionally
4092 (if or_expr is present) OR the (expression != 0) condition to it. */
4095 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4100 /* Calculate (ubound - lbound + 1). */
4101 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4103 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4104 gfc_index_one_node);
4106 /* Check whether the size for this dimension is negative. */
4107 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4108 gfc_index_zero_node);
4109 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4110 gfc_index_zero_node, res);
4112 /* Build OR expression. */
4114 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4115 boolean_type_node, *or_expr, cond);
4121 /* For an array descriptor, get the total number of elements. This is just
4122 the product of the extents along from_dim to to_dim. */
4125 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4130 res = gfc_index_one_node;
4132 for (dim = from_dim; dim < to_dim; ++dim)
4138 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4139 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4141 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4142 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4150 /* Full size of an array. */
4153 gfc_conv_descriptor_size (tree desc, int rank)
4155 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4159 /* Size of a coarray for all dimensions but the last. */
4162 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4164 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4168 /* Fills in an array descriptor, and returns the size of the array.
4169 The size will be a simple_val, ie a variable or a constant. Also
4170 calculates the offset of the base. The pointer argument overflow,
4171 which should be of integer type, will increase in value if overflow
4172 occurs during the size calculation. Returns the size of the array.
4176 for (n = 0; n < rank; n++)
4178 a.lbound[n] = specified_lower_bound;
4179 offset = offset + a.lbond[n] * stride;
4181 a.ubound[n] = specified_upper_bound;
4182 a.stride[n] = stride;
4183 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4184 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4185 stride = stride * size;
4187 for (n = rank; n < rank+corank; n++)
4188 (Set lcobound/ucobound as above.)
4189 element_size = sizeof (array element);
4192 stride = (size_t) stride;
4193 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4194 stride = stride * element_size;
4200 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4201 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4202 stmtblock_t * descriptor_block, tree * overflow)
4215 stmtblock_t thenblock;
4216 stmtblock_t elseblock;
4221 type = TREE_TYPE (descriptor);
4223 stride = gfc_index_one_node;
4224 offset = gfc_index_zero_node;
4226 /* Set the dtype. */
4227 tmp = gfc_conv_descriptor_dtype (descriptor);
4228 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4230 or_expr = boolean_false_node;
4232 for (n = 0; n < rank; n++)
4237 /* We have 3 possibilities for determining the size of the array:
4238 lower == NULL => lbound = 1, ubound = upper[n]
4239 upper[n] = NULL => lbound = 1, ubound = lower[n]
4240 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4243 /* Set lower bound. */
4244 gfc_init_se (&se, NULL);
4246 se.expr = gfc_index_one_node;
4249 gcc_assert (lower[n]);
4252 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4253 gfc_add_block_to_block (pblock, &se.pre);
4257 se.expr = gfc_index_one_node;
4261 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4262 gfc_rank_cst[n], se.expr);
4263 conv_lbound = se.expr;
4265 /* Work out the offset for this component. */
4266 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4268 offset = fold_build2_loc (input_location, MINUS_EXPR,
4269 gfc_array_index_type, offset, tmp);
4271 /* Set upper bound. */
4272 gfc_init_se (&se, NULL);
4273 gcc_assert (ubound);
4274 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4275 gfc_add_block_to_block (pblock, &se.pre);
4277 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4278 gfc_rank_cst[n], se.expr);
4279 conv_ubound = se.expr;
4281 /* Store the stride. */
4282 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4283 gfc_rank_cst[n], stride);
4285 /* Calculate size and check whether extent is negative. */
4286 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4287 size = gfc_evaluate_now (size, pblock);
4289 /* Check whether multiplying the stride by the number of
4290 elements in this dimension would overflow. We must also check
4291 whether the current dimension has zero size in order to avoid
4294 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4295 gfc_array_index_type,
4296 fold_convert (gfc_array_index_type,
4297 TYPE_MAX_VALUE (gfc_array_index_type)),
4299 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4300 boolean_type_node, tmp, stride));
4301 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4302 integer_one_node, integer_zero_node);
4303 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4304 boolean_type_node, size,
4305 gfc_index_zero_node));
4306 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4307 integer_zero_node, tmp);
4308 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4310 *overflow = gfc_evaluate_now (tmp, pblock);
4312 /* Multiply the stride by the number of elements in this dimension. */
4313 stride = fold_build2_loc (input_location, MULT_EXPR,
4314 gfc_array_index_type, stride, size);
4315 stride = gfc_evaluate_now (stride, pblock);
4318 for (n = rank; n < rank + corank; n++)
4322 /* Set lower bound. */
4323 gfc_init_se (&se, NULL);
4324 if (lower == NULL || lower[n] == NULL)
4326 gcc_assert (n == rank + corank - 1);
4327 se.expr = gfc_index_one_node;
4331 if (ubound || n == rank + corank - 1)
4333 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4334 gfc_add_block_to_block (pblock, &se.pre);
4338 se.expr = gfc_index_one_node;
4342 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4343 gfc_rank_cst[n], se.expr);
4345 if (n < rank + corank - 1)
4347 gfc_init_se (&se, NULL);
4348 gcc_assert (ubound);
4349 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4350 gfc_add_block_to_block (pblock, &se.pre);
4351 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4352 gfc_rank_cst[n], se.expr);
4356 /* The stride is the number of elements in the array, so multiply by the
4357 size of an element to get the total size. */
4358 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4359 /* Convert to size_t. */
4360 element_size = fold_convert (size_type_node, tmp);
4363 return element_size;
4365 stride = fold_convert (size_type_node, stride);
4367 /* First check for overflow. Since an array of type character can
4368 have zero element_size, we must check for that before
4370 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4372 TYPE_MAX_VALUE (size_type_node), element_size);
4373 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4374 boolean_type_node, tmp, stride));
4375 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4376 integer_one_node, integer_zero_node);
4377 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4378 boolean_type_node, element_size,
4379 build_int_cst (size_type_node, 0)));
4380 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4381 integer_zero_node, tmp);
4382 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4384 *overflow = gfc_evaluate_now (tmp, pblock);
4386 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4387 stride, element_size);
4389 if (poffset != NULL)
4391 offset = gfc_evaluate_now (offset, pblock);
4395 if (integer_zerop (or_expr))
4397 if (integer_onep (or_expr))
4398 return build_int_cst (size_type_node, 0);
4400 var = gfc_create_var (TREE_TYPE (size), "size");
4401 gfc_start_block (&thenblock);
4402 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4403 thencase = gfc_finish_block (&thenblock);
4405 gfc_start_block (&elseblock);
4406 gfc_add_modify (&elseblock, var, size);
4407 elsecase = gfc_finish_block (&elseblock);
4409 tmp = gfc_evaluate_now (or_expr, pblock);
4410 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4411 gfc_add_expr_to_block (pblock, tmp);
4417 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4418 the work for an ALLOCATE statement. */
4422 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4427 tree offset = NULL_TREE;
4428 tree token = NULL_TREE;
4431 tree error = NULL_TREE;
4432 tree overflow; /* Boolean storing whether size calculation overflows. */
4433 tree var_overflow = NULL_TREE;
4435 tree set_descriptor;
4436 stmtblock_t set_descriptor_block;
4437 stmtblock_t elseblock;
4440 gfc_ref *ref, *prev_ref = NULL;
4441 bool allocatable, coarray, dimension;
4445 /* Find the last reference in the chain. */
4446 while (ref && ref->next != NULL)
4448 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4449 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4454 if (ref == NULL || ref->type != REF_ARRAY)
4459 allocatable = expr->symtree->n.sym->attr.allocatable;
4460 coarray = expr->symtree->n.sym->attr.codimension;
4461 dimension = expr->symtree->n.sym->attr.dimension;
4465 allocatable = prev_ref->u.c.component->attr.allocatable;
4466 coarray = prev_ref->u.c.component->attr.codimension;
4467 dimension = prev_ref->u.c.component->attr.dimension;
4471 gcc_assert (coarray);
4473 /* Figure out the size of the array. */
4474 switch (ref->u.ar.type)
4480 upper = ref->u.ar.start;
4486 lower = ref->u.ar.start;
4487 upper = ref->u.ar.end;
4491 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4493 lower = ref->u.ar.as->lower;
4494 upper = ref->u.ar.as->upper;
4502 overflow = integer_zero_node;
4504 gfc_init_block (&set_descriptor_block);
4505 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4506 ref->u.ar.as->corank, &offset, lower, upper,
4507 &se->pre, &set_descriptor_block, &overflow);
4512 var_overflow = gfc_create_var (integer_type_node, "overflow");
4513 gfc_add_modify (&se->pre, var_overflow, overflow);
4515 /* Generate the block of code handling overflow. */
4516 msg = gfc_build_addr_expr (pchar_type_node,
4517 gfc_build_localized_cstring_const
4518 ("Integer overflow when calculating the amount of "
4519 "memory to allocate"));
4520 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4524 if (status != NULL_TREE)
4526 tree status_type = TREE_TYPE (status);
4527 stmtblock_t set_status_block;
4529 gfc_start_block (&set_status_block);
4530 gfc_add_modify (&set_status_block, status,
4531 build_int_cst (status_type, LIBERROR_ALLOCATION));
4532 error = gfc_finish_block (&set_status_block);
4535 gfc_start_block (&elseblock);
4537 /* Allocate memory to store the data. */
4538 pointer = gfc_conv_descriptor_data_get (se->expr);
4539 STRIP_NOPS (pointer);
4541 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4542 token = gfc_build_addr_expr (NULL_TREE,
4543 gfc_conv_descriptor_token (se->expr));
4545 /* The allocatable variant takes the old pointer as first argument. */
4547 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4548 status, errmsg, errlen, expr);
4550 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4554 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4555 boolean_type_node, var_overflow, integer_zero_node));
4556 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4557 error, gfc_finish_block (&elseblock));
4560 tmp = gfc_finish_block (&elseblock);
4562 gfc_add_expr_to_block (&se->pre, tmp);
4564 /* Update the array descriptors. */
4566 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4568 set_descriptor = gfc_finish_block (&set_descriptor_block);
4569 if (status != NULL_TREE)
4571 cond = fold_build2_loc (input_location, EQ_EXPR,
4572 boolean_type_node, status,
4573 build_int_cst (TREE_TYPE (status), 0));
4574 gfc_add_expr_to_block (&se->pre,
4575 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4576 gfc_likely (cond), set_descriptor,
4577 build_empty_stmt (input_location)));
4580 gfc_add_expr_to_block (&se->pre, set_descriptor);
4582 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4583 && expr->ts.u.derived->attr.alloc_comp)
4585 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4586 ref->u.ar.as->rank);
4587 gfc_add_expr_to_block (&se->pre, tmp);
4594 /* Deallocate an array variable. Also used when an allocated variable goes
4599 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4605 gfc_start_block (&block);
4606 /* Get a pointer to the data. */
4607 var = gfc_conv_descriptor_data_get (descriptor);
4610 /* Parameter is the address of the data component. */
4611 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4612 gfc_add_expr_to_block (&block, tmp);
4614 /* Zero the data pointer. */
4615 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4616 var, build_int_cst (TREE_TYPE (var), 0));
4617 gfc_add_expr_to_block (&block, tmp);
4619 return gfc_finish_block (&block);
4623 /* Create an array constructor from an initialization expression.
4624 We assume the frontend already did any expansions and conversions. */
4627 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4633 unsigned HOST_WIDE_INT lo;
4635 VEC(constructor_elt,gc) *v = NULL;
4637 switch (expr->expr_type)
4640 case EXPR_STRUCTURE:
4641 /* A single scalar or derived type value. Create an array with all
4642 elements equal to that value. */
4643 gfc_init_se (&se, NULL);
4645 if (expr->expr_type == EXPR_CONSTANT)
4646 gfc_conv_constant (&se, expr);
4648 gfc_conv_structure (&se, expr, 1);
4650 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4651 gcc_assert (tmp && INTEGER_CST_P (tmp));
4652 hi = TREE_INT_CST_HIGH (tmp);
4653 lo = TREE_INT_CST_LOW (tmp);
4657 /* This will probably eat buckets of memory for large arrays. */
4658 while (hi != 0 || lo != 0)
4660 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4668 /* Create a vector of all the elements. */
4669 for (c = gfc_constructor_first (expr->value.constructor);
4670 c; c = gfc_constructor_next (c))
4674 /* Problems occur when we get something like
4675 integer :: a(lots) = (/(i, i=1, lots)/) */
4676 gfc_fatal_error ("The number of elements in the array constructor "
4677 "at %L requires an increase of the allowed %d "
4678 "upper limit. See -fmax-array-constructor "
4679 "option", &expr->where,
4680 gfc_option.flag_max_array_constructor);
4683 if (mpz_cmp_si (c->offset, 0) != 0)
4684 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4688 if (mpz_cmp_si (c->repeat, 1) > 0)
4694 mpz_add (maxval, c->offset, c->repeat);
4695 mpz_sub_ui (maxval, maxval, 1);
4696 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4697 if (mpz_cmp_si (c->offset, 0) != 0)
4699 mpz_add_ui (maxval, c->offset, 1);
4700 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4703 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4705 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4711 gfc_init_se (&se, NULL);
4712 switch (c->expr->expr_type)
4715 gfc_conv_constant (&se, c->expr);
4718 case EXPR_STRUCTURE:
4719 gfc_conv_structure (&se, c->expr, 1);
4723 /* Catch those occasional beasts that do not simplify
4724 for one reason or another, assuming that if they are
4725 standard defying the frontend will catch them. */
4726 gfc_conv_expr (&se, c->expr);
4730 if (range == NULL_TREE)
4731 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4734 if (index != NULL_TREE)
4735 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4736 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4742 return gfc_build_null_descriptor (type);
4748 /* Create a constructor from the list of elements. */
4749 tmp = build_constructor (type, v);
4750 TREE_CONSTANT (tmp) = 1;
4755 /* Generate code to evaluate non-constant coarray cobounds. */
4758 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4759 const gfc_symbol *sym)
4769 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4771 /* Evaluate non-constant array bound expressions. */
4772 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4773 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4775 gfc_init_se (&se, NULL);
4776 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4777 gfc_add_block_to_block (pblock, &se.pre);
4778 gfc_add_modify (pblock, lbound, se.expr);
4780 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4781 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4783 gfc_init_se (&se, NULL);
4784 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4785 gfc_add_block_to_block (pblock, &se.pre);
4786 gfc_add_modify (pblock, ubound, se.expr);
4792 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4793 returns the size (in elements) of the array. */
4796 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4797 stmtblock_t * pblock)
4812 size = gfc_index_one_node;
4813 offset = gfc_index_zero_node;
4814 for (dim = 0; dim < as->rank; dim++)
4816 /* Evaluate non-constant array bound expressions. */
4817 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4818 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4820 gfc_init_se (&se, NULL);
4821 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4822 gfc_add_block_to_block (pblock, &se.pre);
4823 gfc_add_modify (pblock, lbound, se.expr);
4825 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4826 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4828 gfc_init_se (&se, NULL);
4829 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4830 gfc_add_block_to_block (pblock, &se.pre);
4831 gfc_add_modify (pblock, ubound, se.expr);
4833 /* The offset of this dimension. offset = offset - lbound * stride. */
4834 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4836 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4839 /* The size of this dimension, and the stride of the next. */
4840 if (dim + 1 < as->rank)
4841 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4843 stride = GFC_TYPE_ARRAY_SIZE (type);
4845 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4847 /* Calculate stride = size * (ubound + 1 - lbound). */
4848 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4849 gfc_array_index_type,
4850 gfc_index_one_node, lbound);
4851 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4852 gfc_array_index_type, ubound, tmp);
4853 tmp = fold_build2_loc (input_location, MULT_EXPR,
4854 gfc_array_index_type, size, tmp);
4856 gfc_add_modify (pblock, stride, tmp);
4858 stride = gfc_evaluate_now (tmp, pblock);
4860 /* Make sure that negative size arrays are translated
4861 to being zero size. */
4862 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4863 stride, gfc_index_zero_node);
4864 tmp = fold_build3_loc (input_location, COND_EXPR,
4865 gfc_array_index_type, tmp,
4866 stride, gfc_index_zero_node);
4867 gfc_add_modify (pblock, stride, tmp);
4873 gfc_trans_array_cobounds (type, pblock, sym);
4874 gfc_trans_vla_type_sizes (sym, pblock);
4881 /* Generate code to initialize/allocate an array variable. */
4884 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4885 gfc_wrapped_block * block)
4889 tree tmp = NULL_TREE;
4896 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4898 /* Do nothing for USEd variables. */
4899 if (sym->attr.use_assoc)
4902 type = TREE_TYPE (decl);
4903 gcc_assert (GFC_ARRAY_TYPE_P (type));
4904 onstack = TREE_CODE (type) != POINTER_TYPE;
4906 gfc_init_block (&init);
4908 /* Evaluate character string length. */
4909 if (sym->ts.type == BT_CHARACTER
4910 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4912 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4914 gfc_trans_vla_type_sizes (sym, &init);
4916 /* Emit a DECL_EXPR for this variable, which will cause the
4917 gimplifier to allocate storage, and all that good stuff. */
4918 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4919 gfc_add_expr_to_block (&init, tmp);
4924 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4928 type = TREE_TYPE (type);
4930 gcc_assert (!sym->attr.use_assoc);
4931 gcc_assert (!TREE_STATIC (decl));
4932 gcc_assert (!sym->module);
4934 if (sym->ts.type == BT_CHARACTER
4935 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4936 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4938 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4940 /* Don't actually allocate space for Cray Pointees. */
4941 if (sym->attr.cray_pointee)
4943 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4944 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4946 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4950 if (gfc_option.flag_stack_arrays)
4952 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
4953 space = build_decl (sym->declared_at.lb->location,
4954 VAR_DECL, create_tmp_var_name ("A"),
4955 TREE_TYPE (TREE_TYPE (decl)));
4956 gfc_trans_vla_type_sizes (sym, &init);
4960 /* The size is the number of elements in the array, so multiply by the
4961 size of an element to get the total size. */
4962 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4963 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4964 size, fold_convert (gfc_array_index_type, tmp));
4966 /* Allocate memory to hold the data. */
4967 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4968 gfc_add_modify (&init, decl, tmp);
4970 /* Free the temporary. */
4971 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4975 /* Set offset of the array. */
4976 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4977 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4979 /* Automatic arrays should not have initializers. */
4980 gcc_assert (!sym->value);
4982 inittree = gfc_finish_block (&init);
4989 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
4990 where also space is located. */
4991 gfc_init_block (&init);
4992 tmp = fold_build1_loc (input_location, DECL_EXPR,
4993 TREE_TYPE (space), space);
4994 gfc_add_expr_to_block (&init, tmp);
4995 addr = fold_build1_loc (sym->declared_at.lb->location,
4996 ADDR_EXPR, TREE_TYPE (decl), space);
4997 gfc_add_modify (&init, decl, addr);
4998 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5001 gfc_add_init_cleanup (block, inittree, tmp);
5005 /* Generate entry and exit code for g77 calling convention arrays. */
5008 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5018 gfc_save_backend_locus (&loc);
5019 gfc_set_backend_locus (&sym->declared_at);
5021 /* Descriptor type. */
5022 parm = sym->backend_decl;
5023 type = TREE_TYPE (parm);
5024 gcc_assert (GFC_ARRAY_TYPE_P (type));
5026 gfc_start_block (&init);
5028 if (sym->ts.type == BT_CHARACTER
5029 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5030 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5032 /* Evaluate the bounds of the array. */
5033 gfc_trans_array_bounds (type, sym, &offset, &init);
5035 /* Set the offset. */
5036 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5037 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5039 /* Set the pointer itself if we aren't using the parameter directly. */
5040 if (TREE_CODE (parm) != PARM_DECL)
5042 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5043 gfc_add_modify (&init, parm, tmp);
5045 stmt = gfc_finish_block (&init);
5047 gfc_restore_backend_locus (&loc);
5049 /* Add the initialization code to the start of the function. */
5051 if (sym->attr.optional || sym->attr.not_always_present)
5053 tmp = gfc_conv_expr_present (sym);
5054 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5057 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5061 /* Modify the descriptor of an array parameter so that it has the
5062 correct lower bound. Also move the upper bound accordingly.
5063 If the array is not packed, it will be copied into a temporary.
5064 For each dimension we set the new lower and upper bounds. Then we copy the
5065 stride and calculate the offset for this dimension. We also work out
5066 what the stride of a packed array would be, and see it the two match.
5067 If the array need repacking, we set the stride to the values we just
5068 calculated, recalculate the offset and copy the array data.
5069 Code is also added to copy the data back at the end of the function.
5073 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5074 gfc_wrapped_block * block)
5081 tree stmtInit, stmtCleanup;
5088 tree stride, stride2;
5098 /* Do nothing for pointer and allocatable arrays. */
5099 if (sym->attr.pointer || sym->attr.allocatable)
5102 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5104 gfc_trans_g77_array (sym, block);
5108 gfc_save_backend_locus (&loc);
5109 gfc_set_backend_locus (&sym->declared_at);
5111 /* Descriptor type. */
5112 type = TREE_TYPE (tmpdesc);
5113 gcc_assert (GFC_ARRAY_TYPE_P (type));
5114 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5115 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5116 gfc_start_block (&init);
5118 if (sym->ts.type == BT_CHARACTER
5119 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5120 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5122 checkparm = (sym->as->type == AS_EXPLICIT
5123 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5125 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5126 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5128 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5130 /* For non-constant shape arrays we only check if the first dimension
5131 is contiguous. Repacking higher dimensions wouldn't gain us
5132 anything as we still don't know the array stride. */
5133 partial = gfc_create_var (boolean_type_node, "partial");
5134 TREE_USED (partial) = 1;
5135 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5136 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5137 gfc_index_one_node);
5138 gfc_add_modify (&init, partial, tmp);
5141 partial = NULL_TREE;
5143 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5144 here, however I think it does the right thing. */
5147 /* Set the first stride. */
5148 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5149 stride = gfc_evaluate_now (stride, &init);
5151 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5152 stride, gfc_index_zero_node);
5153 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5154 tmp, gfc_index_one_node, stride);
5155 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5156 gfc_add_modify (&init, stride, tmp);
5158 /* Allow the user to disable array repacking. */
5159 stmt_unpacked = NULL_TREE;
5163 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5164 /* A library call to repack the array if necessary. */
5165 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5166 stmt_unpacked = build_call_expr_loc (input_location,
5167 gfor_fndecl_in_pack, 1, tmp);
5169 stride = gfc_index_one_node;
5171 if (gfc_option.warn_array_temp)
5172 gfc_warning ("Creating array temporary at %L", &loc);
5175 /* This is for the case where the array data is used directly without
5176 calling the repack function. */
5177 if (no_repack || partial != NULL_TREE)
5178 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5180 stmt_packed = NULL_TREE;
5182 /* Assign the data pointer. */
5183 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5185 /* Don't repack unknown shape arrays when the first stride is 1. */
5186 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5187 partial, stmt_packed, stmt_unpacked);
5190 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5191 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5193 offset = gfc_index_zero_node;
5194 size = gfc_index_one_node;
5196 /* Evaluate the bounds of the array. */
5197 for (n = 0; n < sym->as->rank; n++)
5199 if (checkparm || !sym->as->upper[n])
5201 /* Get the bounds of the actual parameter. */
5202 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5203 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5207 dubound = NULL_TREE;
5208 dlbound = NULL_TREE;
5211 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5212 if (!INTEGER_CST_P (lbound))
5214 gfc_init_se (&se, NULL);
5215 gfc_conv_expr_type (&se, sym->as->lower[n],
5216 gfc_array_index_type);
5217 gfc_add_block_to_block (&init, &se.pre);
5218 gfc_add_modify (&init, lbound, se.expr);
5221 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5222 /* Set the desired upper bound. */
5223 if (sym->as->upper[n])
5225 /* We know what we want the upper bound to be. */
5226 if (!INTEGER_CST_P (ubound))
5228 gfc_init_se (&se, NULL);
5229 gfc_conv_expr_type (&se, sym->as->upper[n],
5230 gfc_array_index_type);
5231 gfc_add_block_to_block (&init, &se.pre);
5232 gfc_add_modify (&init, ubound, se.expr);
5235 /* Check the sizes match. */
5238 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5242 temp = fold_build2_loc (input_location, MINUS_EXPR,
5243 gfc_array_index_type, ubound, lbound);
5244 temp = fold_build2_loc (input_location, PLUS_EXPR,
5245 gfc_array_index_type,
5246 gfc_index_one_node, temp);
5247 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5248 gfc_array_index_type, dubound,
5250 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5251 gfc_array_index_type,
5252 gfc_index_one_node, stride2);
5253 tmp = fold_build2_loc (input_location, NE_EXPR,
5254 gfc_array_index_type, temp, stride2);
5255 asprintf (&msg, "Dimension %d of array '%s' has extent "
5256 "%%ld instead of %%ld", n+1, sym->name);
5258 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5259 fold_convert (long_integer_type_node, temp),
5260 fold_convert (long_integer_type_node, stride2));
5267 /* For assumed shape arrays move the upper bound by the same amount
5268 as the lower bound. */
5269 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5270 gfc_array_index_type, dubound, dlbound);
5271 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5272 gfc_array_index_type, tmp, lbound);
5273 gfc_add_modify (&init, ubound, tmp);
5275 /* The offset of this dimension. offset = offset - lbound * stride. */
5276 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5278 offset = fold_build2_loc (input_location, MINUS_EXPR,
5279 gfc_array_index_type, offset, tmp);
5281 /* The size of this dimension, and the stride of the next. */
5282 if (n + 1 < sym->as->rank)
5284 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5286 if (no_repack || partial != NULL_TREE)
5288 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5290 /* Figure out the stride if not a known constant. */
5291 if (!INTEGER_CST_P (stride))
5294 stmt_packed = NULL_TREE;
5297 /* Calculate stride = size * (ubound + 1 - lbound). */
5298 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5299 gfc_array_index_type,
5300 gfc_index_one_node, lbound);
5301 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5302 gfc_array_index_type, ubound, tmp);
5303 size = fold_build2_loc (input_location, MULT_EXPR,
5304 gfc_array_index_type, size, tmp);
5308 /* Assign the stride. */
5309 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5310 tmp = fold_build3_loc (input_location, COND_EXPR,
5311 gfc_array_index_type, partial,
5312 stmt_unpacked, stmt_packed);
5314 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5315 gfc_add_modify (&init, stride, tmp);
5320 stride = GFC_TYPE_ARRAY_SIZE (type);
5322 if (stride && !INTEGER_CST_P (stride))
5324 /* Calculate size = stride * (ubound + 1 - lbound). */
5325 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5326 gfc_array_index_type,
5327 gfc_index_one_node, lbound);
5328 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5329 gfc_array_index_type,
5331 tmp = fold_build2_loc (input_location, MULT_EXPR,
5332 gfc_array_index_type,
5333 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5334 gfc_add_modify (&init, stride, tmp);
5339 gfc_trans_array_cobounds (type, &init, sym);
5341 /* Set the offset. */
5342 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5343 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5345 gfc_trans_vla_type_sizes (sym, &init);
5347 stmtInit = gfc_finish_block (&init);
5349 /* Only do the entry/initialization code if the arg is present. */
5350 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5351 optional_arg = (sym->attr.optional
5352 || (sym->ns->proc_name->attr.entry_master
5353 && sym->attr.dummy));
5356 tmp = gfc_conv_expr_present (sym);
5357 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5358 build_empty_stmt (input_location));
5363 stmtCleanup = NULL_TREE;
5366 stmtblock_t cleanup;
5367 gfc_start_block (&cleanup);
5369 if (sym->attr.intent != INTENT_IN)
5371 /* Copy the data back. */
5372 tmp = build_call_expr_loc (input_location,
5373 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5374 gfc_add_expr_to_block (&cleanup, tmp);
5377 /* Free the temporary. */
5378 tmp = gfc_call_free (tmpdesc);
5379 gfc_add_expr_to_block (&cleanup, tmp);
5381 stmtCleanup = gfc_finish_block (&cleanup);
5383 /* Only do the cleanup if the array was repacked. */
5384 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5385 tmp = gfc_conv_descriptor_data_get (tmp);
5386 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5388 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5389 build_empty_stmt (input_location));
5393 tmp = gfc_conv_expr_present (sym);
5394 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5395 build_empty_stmt (input_location));
5399 /* We don't need to free any memory allocated by internal_pack as it will
5400 be freed at the end of the function by pop_context. */
5401 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5403 gfc_restore_backend_locus (&loc);
5407 /* Calculate the overall offset, including subreferences. */
5409 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5410 bool subref, gfc_expr *expr)
5420 /* If offset is NULL and this is not a subreferenced array, there is
5422 if (offset == NULL_TREE)
5425 offset = gfc_index_zero_node;
5430 tmp = gfc_conv_array_data (desc);
5431 tmp = build_fold_indirect_ref_loc (input_location,
5433 tmp = gfc_build_array_ref (tmp, offset, NULL);
5435 /* Offset the data pointer for pointer assignments from arrays with
5436 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5439 /* Go past the array reference. */
5440 for (ref = expr->ref; ref; ref = ref->next)
5441 if (ref->type == REF_ARRAY &&
5442 ref->u.ar.type != AR_ELEMENT)
5448 /* Calculate the offset for each subsequent subreference. */
5449 for (; ref; ref = ref->next)
5454 field = ref->u.c.component->backend_decl;
5455 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5456 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5458 tmp, field, NULL_TREE);
5462 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5463 gfc_init_se (&start, NULL);
5464 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5465 gfc_add_block_to_block (block, &start.pre);
5466 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5470 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5471 && ref->u.ar.type == AR_ELEMENT);
5473 /* TODO - Add bounds checking. */
5474 stride = gfc_index_one_node;
5475 index = gfc_index_zero_node;
5476 for (n = 0; n < ref->u.ar.dimen; n++)
5481 /* Update the index. */
5482 gfc_init_se (&start, NULL);
5483 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5484 itmp = gfc_evaluate_now (start.expr, block);
5485 gfc_init_se (&start, NULL);
5486 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5487 jtmp = gfc_evaluate_now (start.expr, block);
5488 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5489 gfc_array_index_type, itmp, jtmp);
5490 itmp = fold_build2_loc (input_location, MULT_EXPR,
5491 gfc_array_index_type, itmp, stride);
5492 index = fold_build2_loc (input_location, PLUS_EXPR,
5493 gfc_array_index_type, itmp, index);
5494 index = gfc_evaluate_now (index, block);
5496 /* Update the stride. */
5497 gfc_init_se (&start, NULL);
5498 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5499 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5500 gfc_array_index_type, start.expr,
5502 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5503 gfc_array_index_type,
5504 gfc_index_one_node, itmp);
5505 stride = fold_build2_loc (input_location, MULT_EXPR,
5506 gfc_array_index_type, stride, itmp);
5507 stride = gfc_evaluate_now (stride, block);
5510 /* Apply the index to obtain the array element. */
5511 tmp = gfc_build_array_ref (tmp, index, NULL);
5521 /* Set the target data pointer. */
5522 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5523 gfc_conv_descriptor_data_set (block, parm, offset);
5527 /* gfc_conv_expr_descriptor needs the string length an expression
5528 so that the size of the temporary can be obtained. This is done
5529 by adding up the string lengths of all the elements in the
5530 expression. Function with non-constant expressions have their
5531 string lengths mapped onto the actual arguments using the
5532 interface mapping machinery in trans-expr.c. */
5534 get_array_charlen (gfc_expr *expr, gfc_se *se)
5536 gfc_interface_mapping mapping;
5537 gfc_formal_arglist *formal;
5538 gfc_actual_arglist *arg;
5541 if (expr->ts.u.cl->length
5542 && gfc_is_constant_expr (expr->ts.u.cl->length))
5544 if (!expr->ts.u.cl->backend_decl)
5545 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5549 switch (expr->expr_type)
5552 get_array_charlen (expr->value.op.op1, se);
5554 /* For parentheses the expression ts.u.cl is identical. */
5555 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5558 expr->ts.u.cl->backend_decl =
5559 gfc_create_var (gfc_charlen_type_node, "sln");
5561 if (expr->value.op.op2)
5563 get_array_charlen (expr->value.op.op2, se);
5565 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5567 /* Add the string lengths and assign them to the expression
5568 string length backend declaration. */
5569 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5570 fold_build2_loc (input_location, PLUS_EXPR,
5571 gfc_charlen_type_node,
5572 expr->value.op.op1->ts.u.cl->backend_decl,
5573 expr->value.op.op2->ts.u.cl->backend_decl));
5576 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5577 expr->value.op.op1->ts.u.cl->backend_decl);
5581 if (expr->value.function.esym == NULL
5582 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5584 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5588 /* Map expressions involving the dummy arguments onto the actual
5589 argument expressions. */
5590 gfc_init_interface_mapping (&mapping);
5591 formal = expr->symtree->n.sym->formal;
5592 arg = expr->value.function.actual;
5594 /* Set se = NULL in the calls to the interface mapping, to suppress any
5596 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5601 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5604 gfc_init_se (&tse, NULL);
5606 /* Build the expression for the character length and convert it. */
5607 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5609 gfc_add_block_to_block (&se->pre, &tse.pre);
5610 gfc_add_block_to_block (&se->post, &tse.post);
5611 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5612 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5613 gfc_charlen_type_node, tse.expr,
5614 build_int_cst (gfc_charlen_type_node, 0));
5615 expr->ts.u.cl->backend_decl = tse.expr;
5616 gfc_free_interface_mapping (&mapping);
5620 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5625 /* Helper function to check dimensions. */
5627 dim_ok (gfc_ss_info *info)
5630 for (n = 0; n < info->dimen; n++)
5631 if (info->dim[n] != n)
5636 /* Convert an array for passing as an actual argument. Expressions and
5637 vector subscripts are evaluated and stored in a temporary, which is then
5638 passed. For whole arrays the descriptor is passed. For array sections
5639 a modified copy of the descriptor is passed, but using the original data.
5641 This function is also used for array pointer assignments, and there
5644 - se->want_pointer && !se->direct_byref
5645 EXPR is an actual argument. On exit, se->expr contains a
5646 pointer to the array descriptor.
5648 - !se->want_pointer && !se->direct_byref
5649 EXPR is an actual argument to an intrinsic function or the
5650 left-hand side of a pointer assignment. On exit, se->expr
5651 contains the descriptor for EXPR.
5653 - !se->want_pointer && se->direct_byref
5654 EXPR is the right-hand side of a pointer assignment and
5655 se->expr is the descriptor for the previously-evaluated
5656 left-hand side. The function creates an assignment from
5660 The se->force_tmp flag disables the non-copying descriptor optimization
5661 that is used for transpose. It may be used in cases where there is an
5662 alias between the transpose argument and another argument in the same
5666 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5678 bool subref_array_target = false;
5681 gcc_assert (ss != NULL);
5682 gcc_assert (ss != gfc_ss_terminator);
5684 /* Special case things we know we can pass easily. */
5685 switch (expr->expr_type)
5688 /* If we have a linear array section, we can pass it directly.
5689 Otherwise we need to copy it into a temporary. */
5691 gcc_assert (ss->type == GFC_SS_SECTION);
5692 gcc_assert (ss->expr == expr);
5693 info = &ss->data.info;
5695 /* Get the descriptor for the array. */
5696 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5697 desc = info->descriptor;
5699 subref_array_target = se->direct_byref && is_subref_array (expr);
5700 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5701 && !subref_array_target;
5708 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5710 /* Create a new descriptor if the array doesn't have one. */
5713 else if (info->ref->u.ar.type == AR_FULL)
5715 else if (se->direct_byref)
5718 full = gfc_full_array_ref_p (info->ref, NULL);
5720 if (full && dim_ok (info))
5722 if (se->direct_byref && !se->byref_noassign)
5724 /* Copy the descriptor for pointer assignments. */
5725 gfc_add_modify (&se->pre, se->expr, desc);
5727 /* Add any offsets from subreferences. */
5728 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5729 subref_array_target, expr);
5731 else if (se->want_pointer)
5733 /* We pass full arrays directly. This means that pointers and
5734 allocatable arrays should also work. */
5735 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5742 if (expr->ts.type == BT_CHARACTER)
5743 se->string_length = gfc_get_expr_charlen (expr);
5751 /* We don't need to copy data in some cases. */
5752 arg = gfc_get_noncopying_intrinsic_argument (expr);
5755 /* This is a call to transpose... */
5756 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5757 /* ... which has already been handled by the scalarizer, so
5758 that we just need to get its argument's descriptor. */
5759 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5763 /* A transformational function return value will be a temporary
5764 array descriptor. We still need to go through the scalarizer
5765 to create the descriptor. Elemental functions ar handled as
5766 arbitrary expressions, i.e. copy to a temporary. */
5768 if (se->direct_byref)
5770 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5772 /* For pointer assignments pass the descriptor directly. */
5776 gcc_assert (se->ss == ss);
5777 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5778 gfc_conv_expr (se, expr);
5782 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5784 if (ss->expr != expr)
5785 /* Elemental function. */
5786 gcc_assert ((expr->value.function.esym != NULL
5787 && expr->value.function.esym->attr.elemental)
5788 || (expr->value.function.isym != NULL
5789 && expr->value.function.isym->elemental));
5791 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5794 if (expr->ts.type == BT_CHARACTER
5795 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5796 get_array_charlen (expr, se);
5802 /* Transformational function. */
5803 info = &ss->data.info;
5809 /* Constant array constructors don't need a temporary. */
5810 if (ss->type == GFC_SS_CONSTRUCTOR
5811 && expr->ts.type != BT_CHARACTER
5812 && gfc_constant_array_constructor_p (expr->value.constructor))
5815 info = &ss->data.info;
5825 /* Something complicated. Copy it into a temporary. */
5831 /* If we are creating a temporary, we don't need to bother about aliases
5836 gfc_init_loopinfo (&loop);
5838 /* Associate the SS with the loop. */
5839 gfc_add_ss_to_loop (&loop, ss);
5841 /* Tell the scalarizer not to bother creating loop variables, etc. */
5843 loop.array_parameter = 1;
5845 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5846 gcc_assert (!se->direct_byref);
5848 /* Setup the scalarizing loops and bounds. */
5849 gfc_conv_ss_startstride (&loop);
5853 /* Tell the scalarizer to make a temporary. */
5854 loop.temp_ss = gfc_get_ss ();
5855 loop.temp_ss->type = GFC_SS_TEMP;
5856 loop.temp_ss->next = gfc_ss_terminator;
5858 if (expr->ts.type == BT_CHARACTER
5859 && !expr->ts.u.cl->backend_decl)
5860 get_array_charlen (expr, se);
5862 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5864 if (expr->ts.type == BT_CHARACTER)
5865 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5867 loop.temp_ss->string_length = NULL;
5869 se->string_length = loop.temp_ss->string_length;
5870 loop.temp_ss->data.temp.dimen = loop.dimen;
5871 loop.temp_ss->data.temp.codimen = loop.codimen;
5872 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5875 gfc_conv_loop_setup (&loop, & expr->where);
5879 /* Copy into a temporary and pass that. We don't need to copy the data
5880 back because expressions and vector subscripts must be INTENT_IN. */
5881 /* TODO: Optimize passing function return values. */
5885 /* Start the copying loops. */
5886 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5887 gfc_mark_ss_chain_used (ss, 1);
5888 gfc_start_scalarized_body (&loop, &block);
5890 /* Copy each data element. */
5891 gfc_init_se (&lse, NULL);
5892 gfc_copy_loopinfo_to_se (&lse, &loop);
5893 gfc_init_se (&rse, NULL);
5894 gfc_copy_loopinfo_to_se (&rse, &loop);
5896 lse.ss = loop.temp_ss;
5899 gfc_conv_scalarized_array_ref (&lse, NULL);
5900 if (expr->ts.type == BT_CHARACTER)
5902 gfc_conv_expr (&rse, expr);
5903 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5904 rse.expr = build_fold_indirect_ref_loc (input_location,
5908 gfc_conv_expr_val (&rse, expr);
5910 gfc_add_block_to_block (&block, &rse.pre);
5911 gfc_add_block_to_block (&block, &lse.pre);
5913 lse.string_length = rse.string_length;
5914 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5915 expr->expr_type == EXPR_VARIABLE
5916 || expr->expr_type == EXPR_ARRAY, true);
5917 gfc_add_expr_to_block (&block, tmp);
5919 /* Finish the copying loops. */
5920 gfc_trans_scalarizing_loops (&loop, &block);
5922 desc = loop.temp_ss->data.info.descriptor;
5924 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5926 desc = info->descriptor;
5927 se->string_length = ss->string_length;
5931 /* We pass sections without copying to a temporary. Make a new
5932 descriptor and point it at the section we want. The loop variable
5933 limits will be the limits of the section.
5934 A function may decide to repack the array to speed up access, but
5935 we're not bothered about that here. */
5936 int dim, ndim, codim;
5944 /* Set the string_length for a character array. */
5945 if (expr->ts.type == BT_CHARACTER)
5946 se->string_length = gfc_get_expr_charlen (expr);
5948 desc = info->descriptor;
5949 if (se->direct_byref && !se->byref_noassign)
5951 /* For pointer assignments we fill in the destination. */
5953 parmtype = TREE_TYPE (parm);
5957 /* Otherwise make a new one. */
5958 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5959 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5960 loop.codimen, loop.from,
5962 GFC_ARRAY_UNKNOWN, false);
5963 parm = gfc_create_var (parmtype, "parm");
5966 offset = gfc_index_zero_node;
5968 /* The following can be somewhat confusing. We have two
5969 descriptors, a new one and the original array.
5970 {parm, parmtype, dim} refer to the new one.
5971 {desc, type, n, loop} refer to the original, which maybe
5972 a descriptorless array.
5973 The bounds of the scalarization are the bounds of the section.
5974 We don't have to worry about numeric overflows when calculating
5975 the offsets because all elements are within the array data. */
5977 /* Set the dtype. */
5978 tmp = gfc_conv_descriptor_dtype (parm);
5979 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5981 /* Set offset for assignments to pointer only to zero if it is not
5983 if (se->direct_byref
5984 && info->ref && info->ref->u.ar.type != AR_FULL)
5985 base = gfc_index_zero_node;
5986 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5987 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5991 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5992 codim = info->codimen;
5993 for (n = 0; n < ndim; n++)
5995 stride = gfc_conv_array_stride (desc, n);
5997 /* Work out the offset. */
5999 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6001 gcc_assert (info->subscript[n]
6002 && info->subscript[n]->type == GFC_SS_SCALAR);
6003 start = info->subscript[n]->data.scalar.expr;
6007 /* Evaluate and remember the start of the section. */
6008 start = info->start[n];
6009 stride = gfc_evaluate_now (stride, &loop.pre);
6012 tmp = gfc_conv_array_lbound (desc, n);
6013 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6015 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6017 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6021 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6023 /* For elemental dimensions, we only need the offset. */
6027 /* Vector subscripts need copying and are handled elsewhere. */
6029 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6031 /* look for the corresponding scalarizer dimension: dim. */
6032 for (dim = 0; dim < ndim; dim++)
6033 if (info->dim[dim] == n)
6036 /* loop exited early: the DIM being looked for has been found. */
6037 gcc_assert (dim < ndim);
6039 /* Set the new lower bound. */
6040 from = loop.from[dim];
6043 /* If we have an array section or are assigning make sure that
6044 the lower bound is 1. References to the full
6045 array should otherwise keep the original bounds. */
6047 || info->ref->u.ar.type != AR_FULL)
6048 && !integer_onep (from))
6050 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6051 gfc_array_index_type, gfc_index_one_node,
6053 to = fold_build2_loc (input_location, PLUS_EXPR,
6054 gfc_array_index_type, to, tmp);
6055 from = gfc_index_one_node;
6057 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6058 gfc_rank_cst[dim], from);
6060 /* Set the new upper bound. */
6061 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6062 gfc_rank_cst[dim], to);
6064 /* Multiply the stride by the section stride to get the
6066 stride = fold_build2_loc (input_location, MULT_EXPR,
6067 gfc_array_index_type,
6068 stride, info->stride[n]);
6070 if (se->direct_byref
6072 && info->ref->u.ar.type != AR_FULL)
6074 base = fold_build2_loc (input_location, MINUS_EXPR,
6075 TREE_TYPE (base), base, stride);
6077 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6079 tmp = gfc_conv_array_lbound (desc, n);
6080 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6081 TREE_TYPE (base), tmp, loop.from[dim]);
6082 tmp = fold_build2_loc (input_location, MULT_EXPR,
6083 TREE_TYPE (base), tmp,
6084 gfc_conv_array_stride (desc, n));
6085 base = fold_build2_loc (input_location, PLUS_EXPR,
6086 TREE_TYPE (base), tmp, base);
6089 /* Store the new stride. */
6090 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6091 gfc_rank_cst[dim], stride);
6094 for (n = ndim; n < ndim + codim; n++)
6096 /* look for the corresponding scalarizer dimension: dim. */
6097 for (dim = 0; dim < ndim + codim; dim++)
6098 if (info->dim[dim] == n)
6101 /* loop exited early: the DIM being looked for has been found. */
6102 gcc_assert (dim < ndim + codim);
6104 from = loop.from[dim];
6106 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6107 gfc_rank_cst[dim], from);
6108 if (n < ndim + codim - 1)
6109 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6110 gfc_rank_cst[dim], to);
6114 if (se->data_not_needed)
6115 gfc_conv_descriptor_data_set (&loop.pre, parm,
6116 gfc_index_zero_node);
6118 /* Point the data pointer at the 1st element in the section. */
6119 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6120 subref_array_target, expr);
6122 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6123 && !se->data_not_needed)
6125 /* Set the offset. */
6126 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6130 /* Only the callee knows what the correct offset it, so just set
6132 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6137 if (!se->direct_byref || se->byref_noassign)
6139 /* Get a pointer to the new descriptor. */
6140 if (se->want_pointer)
6141 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6146 gfc_add_block_to_block (&se->pre, &loop.pre);
6147 gfc_add_block_to_block (&se->post, &loop.post);
6149 /* Cleanup the scalarizer. */
6150 gfc_cleanup_loop (&loop);
6153 /* Helper function for gfc_conv_array_parameter if array size needs to be
6157 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6160 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6161 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6162 else if (expr->rank > 1)
6163 *size = build_call_expr_loc (input_location,
6164 gfor_fndecl_size0, 1,
6165 gfc_build_addr_expr (NULL, desc));
6168 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6169 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6171 *size = fold_build2_loc (input_location, MINUS_EXPR,
6172 gfc_array_index_type, ubound, lbound);
6173 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6174 *size, gfc_index_one_node);
6175 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6176 *size, gfc_index_zero_node);
6178 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6179 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6180 *size, fold_convert (gfc_array_index_type, elem));
6183 /* Convert an array for passing as an actual parameter. */
6184 /* TODO: Optimize passing g77 arrays. */
6187 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6188 const gfc_symbol *fsym, const char *proc_name,
6193 tree tmp = NULL_TREE;
6195 tree parent = DECL_CONTEXT (current_function_decl);
6196 bool full_array_var;
6197 bool this_array_result;
6200 bool array_constructor;
6201 bool good_allocatable;
6202 bool ultimate_ptr_comp;
6203 bool ultimate_alloc_comp;
6208 ultimate_ptr_comp = false;
6209 ultimate_alloc_comp = false;
6211 for (ref = expr->ref; ref; ref = ref->next)
6213 if (ref->next == NULL)
6216 if (ref->type == REF_COMPONENT)
6218 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6219 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6223 full_array_var = false;
6226 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6227 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6229 sym = full_array_var ? expr->symtree->n.sym : NULL;
6231 /* The symbol should have an array specification. */
6232 gcc_assert (!sym || sym->as || ref->u.ar.as);
6234 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6236 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6237 expr->ts.u.cl->backend_decl = tmp;
6238 se->string_length = tmp;
6241 /* Is this the result of the enclosing procedure? */
6242 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6243 if (this_array_result
6244 && (sym->backend_decl != current_function_decl)
6245 && (sym->backend_decl != parent))
6246 this_array_result = false;
6248 /* Passing address of the array if it is not pointer or assumed-shape. */
6249 if (full_array_var && g77 && !this_array_result)
6251 tmp = gfc_get_symbol_decl (sym);
6253 if (sym->ts.type == BT_CHARACTER)
6254 se->string_length = sym->ts.u.cl->backend_decl;
6256 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6258 gfc_conv_expr_descriptor (se, expr, ss);
6259 se->expr = gfc_conv_array_data (se->expr);
6263 if (!sym->attr.pointer
6265 && sym->as->type != AS_ASSUMED_SHAPE
6266 && !sym->attr.allocatable)
6268 /* Some variables are declared directly, others are declared as
6269 pointers and allocated on the heap. */
6270 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6273 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6275 array_parameter_size (tmp, expr, size);
6279 if (sym->attr.allocatable)
6281 if (sym->attr.dummy || sym->attr.result)
6283 gfc_conv_expr_descriptor (se, expr, ss);
6287 array_parameter_size (tmp, expr, size);
6288 se->expr = gfc_conv_array_data (tmp);
6293 /* A convenient reduction in scope. */
6294 contiguous = g77 && !this_array_result && contiguous;
6296 /* There is no need to pack and unpack the array, if it is contiguous
6297 and not a deferred- or assumed-shape array, or if it is simply
6299 no_pack = ((sym && sym->as
6300 && !sym->attr.pointer
6301 && sym->as->type != AS_DEFERRED
6302 && sym->as->type != AS_ASSUMED_SHAPE)
6304 (ref && ref->u.ar.as
6305 && ref->u.ar.as->type != AS_DEFERRED
6306 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6308 gfc_is_simply_contiguous (expr, false));
6310 no_pack = contiguous && no_pack;
6312 /* Array constructors are always contiguous and do not need packing. */
6313 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6315 /* Same is true of contiguous sections from allocatable variables. */
6316 good_allocatable = contiguous
6318 && expr->symtree->n.sym->attr.allocatable;
6320 /* Or ultimate allocatable components. */
6321 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6323 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6325 gfc_conv_expr_descriptor (se, expr, ss);
6326 if (expr->ts.type == BT_CHARACTER)
6327 se->string_length = expr->ts.u.cl->backend_decl;
6329 array_parameter_size (se->expr, expr, size);
6330 se->expr = gfc_conv_array_data (se->expr);
6334 if (this_array_result)
6336 /* Result of the enclosing function. */
6337 gfc_conv_expr_descriptor (se, expr, ss);
6339 array_parameter_size (se->expr, expr, size);
6340 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6342 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6343 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6344 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6351 /* Every other type of array. */
6352 se->want_pointer = 1;
6353 gfc_conv_expr_descriptor (se, expr, ss);
6355 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6360 /* Deallocate the allocatable components of structures that are
6362 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6363 && expr->ts.u.derived->attr.alloc_comp
6364 && expr->expr_type != EXPR_VARIABLE)
6366 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6367 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6369 /* The components shall be deallocated before their containing entity. */
6370 gfc_prepend_expr_to_block (&se->post, tmp);
6373 if (g77 || (fsym && fsym->attr.contiguous
6374 && !gfc_is_simply_contiguous (expr, false)))
6376 tree origptr = NULL_TREE;
6380 /* For contiguous arrays, save the original value of the descriptor. */
6383 origptr = gfc_create_var (pvoid_type_node, "origptr");
6384 tmp = build_fold_indirect_ref_loc (input_location, desc);
6385 tmp = gfc_conv_array_data (tmp);
6386 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6387 TREE_TYPE (origptr), origptr,
6388 fold_convert (TREE_TYPE (origptr), tmp));
6389 gfc_add_expr_to_block (&se->pre, tmp);
6392 /* Repack the array. */
6393 if (gfc_option.warn_array_temp)
6396 gfc_warning ("Creating array temporary at %L for argument '%s'",
6397 &expr->where, fsym->name);
6399 gfc_warning ("Creating array temporary at %L", &expr->where);
6402 ptr = build_call_expr_loc (input_location,
6403 gfor_fndecl_in_pack, 1, desc);
6405 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6407 tmp = gfc_conv_expr_present (sym);
6408 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6409 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6410 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6413 ptr = gfc_evaluate_now (ptr, &se->pre);
6415 /* Use the packed data for the actual argument, except for contiguous arrays,
6416 where the descriptor's data component is set. */
6421 tmp = build_fold_indirect_ref_loc (input_location, desc);
6422 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6425 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6429 if (fsym && proc_name)
6430 asprintf (&msg, "An array temporary was created for argument "
6431 "'%s' of procedure '%s'", fsym->name, proc_name);
6433 asprintf (&msg, "An array temporary was created");
6435 tmp = build_fold_indirect_ref_loc (input_location,
6437 tmp = gfc_conv_array_data (tmp);
6438 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6439 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6441 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6442 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6444 gfc_conv_expr_present (sym), tmp);
6446 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6451 gfc_start_block (&block);
6453 /* Copy the data back. */
6454 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6456 tmp = build_call_expr_loc (input_location,
6457 gfor_fndecl_in_unpack, 2, desc, ptr);
6458 gfc_add_expr_to_block (&block, tmp);
6461 /* Free the temporary. */
6462 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6463 gfc_add_expr_to_block (&block, tmp);
6465 stmt = gfc_finish_block (&block);
6467 gfc_init_block (&block);
6468 /* Only if it was repacked. This code needs to be executed before the
6469 loop cleanup code. */
6470 tmp = build_fold_indirect_ref_loc (input_location,
6472 tmp = gfc_conv_array_data (tmp);
6473 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6474 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6476 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6477 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6479 gfc_conv_expr_present (sym), tmp);
6481 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6483 gfc_add_expr_to_block (&block, tmp);
6484 gfc_add_block_to_block (&block, &se->post);
6486 gfc_init_block (&se->post);
6488 /* Reset the descriptor pointer. */
6491 tmp = build_fold_indirect_ref_loc (input_location, desc);
6492 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6495 gfc_add_block_to_block (&se->post, &block);
6500 /* Generate code to deallocate an array, if it is allocated. */
6503 gfc_trans_dealloc_allocated (tree descriptor)
6509 gfc_start_block (&block);
6511 var = gfc_conv_descriptor_data_get (descriptor);
6514 /* Call array_deallocate with an int * present in the second argument.
6515 Although it is ignored here, it's presence ensures that arrays that
6516 are already deallocated are ignored. */
6517 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6518 gfc_add_expr_to_block (&block, tmp);
6520 /* Zero the data pointer. */
6521 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6522 var, build_int_cst (TREE_TYPE (var), 0));
6523 gfc_add_expr_to_block (&block, tmp);
6525 return gfc_finish_block (&block);
6529 /* This helper function calculates the size in words of a full array. */
6532 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6537 idx = gfc_rank_cst[rank - 1];
6538 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6539 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6540 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6542 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6543 tmp, gfc_index_one_node);
6544 tmp = gfc_evaluate_now (tmp, block);
6546 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6547 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6549 return gfc_evaluate_now (tmp, block);
6553 /* Allocate dest to the same size as src, and copy src -> dest.
6554 If no_malloc is set, only the copy is done. */
6557 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6567 /* If the source is null, set the destination to null. Then,
6568 allocate memory to the destination. */
6569 gfc_init_block (&block);
6573 tmp = null_pointer_node;
6574 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6575 gfc_add_expr_to_block (&block, tmp);
6576 null_data = gfc_finish_block (&block);
6578 gfc_init_block (&block);
6579 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6582 tmp = gfc_call_malloc (&block, type, size);
6583 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6584 dest, fold_convert (type, tmp));
6585 gfc_add_expr_to_block (&block, tmp);
6588 tmp = built_in_decls[BUILT_IN_MEMCPY];
6589 tmp = build_call_expr_loc (input_location, tmp, 3,
6594 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6595 null_data = gfc_finish_block (&block);
6597 gfc_init_block (&block);
6598 nelems = get_full_array_size (&block, src, rank);
6599 tmp = fold_convert (gfc_array_index_type,
6600 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6601 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6605 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6606 tmp = gfc_call_malloc (&block, tmp, size);
6607 gfc_conv_descriptor_data_set (&block, dest, tmp);
6610 /* We know the temporary and the value will be the same length,
6611 so can use memcpy. */
6612 tmp = built_in_decls[BUILT_IN_MEMCPY];
6613 tmp = build_call_expr_loc (input_location,
6614 tmp, 3, gfc_conv_descriptor_data_get (dest),
6615 gfc_conv_descriptor_data_get (src), size);
6618 gfc_add_expr_to_block (&block, tmp);
6619 tmp = gfc_finish_block (&block);
6621 /* Null the destination if the source is null; otherwise do
6622 the allocate and copy. */
6626 null_cond = gfc_conv_descriptor_data_get (src);
6628 null_cond = convert (pvoid_type_node, null_cond);
6629 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6630 null_cond, null_pointer_node);
6631 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6635 /* Allocate dest to the same size as src, and copy data src -> dest. */
6638 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6640 return duplicate_allocatable (dest, src, type, rank, false);
6644 /* Copy data src -> dest. */
6647 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6649 return duplicate_allocatable (dest, src, type, rank, true);
6653 /* Recursively traverse an object of derived type, generating code to
6654 deallocate, nullify or copy allocatable components. This is the work horse
6655 function for the functions named in this enum. */
6657 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6658 COPY_ONLY_ALLOC_COMP};
6661 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6662 tree dest, int rank, int purpose)
6666 stmtblock_t fnblock;
6667 stmtblock_t loopbody;
6678 tree null_cond = NULL_TREE;
6680 gfc_init_block (&fnblock);
6682 decl_type = TREE_TYPE (decl);
6684 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6685 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6687 decl = build_fold_indirect_ref_loc (input_location,
6690 /* Just in case in gets dereferenced. */
6691 decl_type = TREE_TYPE (decl);
6693 /* If this an array of derived types with allocatable components
6694 build a loop and recursively call this function. */
6695 if (TREE_CODE (decl_type) == ARRAY_TYPE
6696 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6698 tmp = gfc_conv_array_data (decl);
6699 var = build_fold_indirect_ref_loc (input_location,
6702 /* Get the number of elements - 1 and set the counter. */
6703 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6705 /* Use the descriptor for an allocatable array. Since this
6706 is a full array reference, we only need the descriptor
6707 information from dimension = rank. */
6708 tmp = get_full_array_size (&fnblock, decl, rank);
6709 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6710 gfc_array_index_type, tmp,
6711 gfc_index_one_node);
6713 null_cond = gfc_conv_descriptor_data_get (decl);
6714 null_cond = fold_build2_loc (input_location, NE_EXPR,
6715 boolean_type_node, null_cond,
6716 build_int_cst (TREE_TYPE (null_cond), 0));
6720 /* Otherwise use the TYPE_DOMAIN information. */
6721 tmp = array_type_nelts (decl_type);
6722 tmp = fold_convert (gfc_array_index_type, tmp);
6725 /* Remember that this is, in fact, the no. of elements - 1. */
6726 nelems = gfc_evaluate_now (tmp, &fnblock);
6727 index = gfc_create_var (gfc_array_index_type, "S");
6729 /* Build the body of the loop. */
6730 gfc_init_block (&loopbody);
6732 vref = gfc_build_array_ref (var, index, NULL);
6734 if (purpose == COPY_ALLOC_COMP)
6736 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6738 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6739 gfc_add_expr_to_block (&fnblock, tmp);
6741 tmp = build_fold_indirect_ref_loc (input_location,
6742 gfc_conv_array_data (dest));
6743 dref = gfc_build_array_ref (tmp, index, NULL);
6744 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6746 else if (purpose == COPY_ONLY_ALLOC_COMP)
6748 tmp = build_fold_indirect_ref_loc (input_location,
6749 gfc_conv_array_data (dest));
6750 dref = gfc_build_array_ref (tmp, index, NULL);
6751 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6755 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6757 gfc_add_expr_to_block (&loopbody, tmp);
6759 /* Build the loop and return. */
6760 gfc_init_loopinfo (&loop);
6762 loop.from[0] = gfc_index_zero_node;
6763 loop.loopvar[0] = index;
6764 loop.to[0] = nelems;
6765 gfc_trans_scalarizing_loops (&loop, &loopbody);
6766 gfc_add_block_to_block (&fnblock, &loop.pre);
6768 tmp = gfc_finish_block (&fnblock);
6769 if (null_cond != NULL_TREE)
6770 tmp = build3_v (COND_EXPR, null_cond, tmp,
6771 build_empty_stmt (input_location));
6776 /* Otherwise, act on the components or recursively call self to
6777 act on a chain of components. */
6778 for (c = der_type->components; c; c = c->next)
6780 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6781 || c->ts.type == BT_CLASS)
6782 && c->ts.u.derived->attr.alloc_comp;
6783 cdecl = c->backend_decl;
6784 ctype = TREE_TYPE (cdecl);
6788 case DEALLOCATE_ALLOC_COMP:
6789 if (cmp_has_alloc_comps && !c->attr.pointer)
6791 /* Do not deallocate the components of ultimate pointer
6793 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6794 decl, cdecl, NULL_TREE);
6795 rank = c->as ? c->as->rank : 0;
6796 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6798 gfc_add_expr_to_block (&fnblock, tmp);
6801 if (c->attr.allocatable && c->attr.dimension)
6803 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6804 decl, cdecl, NULL_TREE);
6805 tmp = gfc_trans_dealloc_allocated (comp);
6806 gfc_add_expr_to_block (&fnblock, tmp);
6808 else if (c->attr.allocatable)
6810 /* Allocatable scalar components. */
6811 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6812 decl, cdecl, NULL_TREE);
6814 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6816 gfc_add_expr_to_block (&fnblock, tmp);
6818 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6819 void_type_node, comp,
6820 build_int_cst (TREE_TYPE (comp), 0));
6821 gfc_add_expr_to_block (&fnblock, tmp);
6823 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6825 /* Allocatable scalar CLASS components. */
6826 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6827 decl, cdecl, NULL_TREE);
6829 /* Add reference to '_data' component. */
6830 tmp = CLASS_DATA (c)->backend_decl;
6831 comp = fold_build3_loc (input_location, COMPONENT_REF,
6832 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6834 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6835 CLASS_DATA (c)->ts);
6836 gfc_add_expr_to_block (&fnblock, tmp);
6838 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6839 void_type_node, comp,
6840 build_int_cst (TREE_TYPE (comp), 0));
6841 gfc_add_expr_to_block (&fnblock, tmp);
6845 case NULLIFY_ALLOC_COMP:
6846 if (c->attr.pointer)
6848 else if (c->attr.allocatable && c->attr.dimension)
6850 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6851 decl, cdecl, NULL_TREE);
6852 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6854 else if (c->attr.allocatable)
6856 /* Allocatable scalar components. */
6857 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6858 decl, cdecl, NULL_TREE);
6859 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6860 void_type_node, comp,
6861 build_int_cst (TREE_TYPE (comp), 0));
6862 gfc_add_expr_to_block (&fnblock, tmp);
6864 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6866 /* Allocatable scalar CLASS components. */
6867 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6868 decl, cdecl, NULL_TREE);
6869 /* Add reference to '_data' component. */
6870 tmp = CLASS_DATA (c)->backend_decl;
6871 comp = fold_build3_loc (input_location, COMPONENT_REF,
6872 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6873 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6874 void_type_node, comp,
6875 build_int_cst (TREE_TYPE (comp), 0));
6876 gfc_add_expr_to_block (&fnblock, tmp);
6878 else if (cmp_has_alloc_comps)
6880 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6881 decl, cdecl, NULL_TREE);
6882 rank = c->as ? c->as->rank : 0;
6883 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6885 gfc_add_expr_to_block (&fnblock, tmp);
6889 case COPY_ALLOC_COMP:
6890 if (c->attr.pointer)
6893 /* We need source and destination components. */
6894 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6896 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6898 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6900 if (c->attr.allocatable && !cmp_has_alloc_comps)
6902 rank = c->as ? c->as->rank : 0;
6903 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6904 gfc_add_expr_to_block (&fnblock, tmp);
6907 if (cmp_has_alloc_comps)
6909 rank = c->as ? c->as->rank : 0;
6910 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6911 gfc_add_modify (&fnblock, dcmp, tmp);
6912 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6914 gfc_add_expr_to_block (&fnblock, tmp);
6924 return gfc_finish_block (&fnblock);
6927 /* Recursively traverse an object of derived type, generating code to
6928 nullify allocatable components. */
6931 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6933 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6934 NULLIFY_ALLOC_COMP);
6938 /* Recursively traverse an object of derived type, generating code to
6939 deallocate allocatable components. */
6942 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6944 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6945 DEALLOCATE_ALLOC_COMP);
6949 /* Recursively traverse an object of derived type, generating code to
6950 copy it and its allocatable components. */
6953 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6955 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6959 /* Recursively traverse an object of derived type, generating code to
6960 copy only its allocatable components. */
6963 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6965 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6969 /* Returns the value of LBOUND for an expression. This could be broken out
6970 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6971 called by gfc_alloc_allocatable_for_assignment. */
6973 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6978 tree cond, cond1, cond3, cond4;
6982 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6984 tmp = gfc_rank_cst[dim];
6985 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6986 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6987 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6988 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6990 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6991 stride, gfc_index_zero_node);
6992 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6993 boolean_type_node, cond3, cond1);
6994 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6995 stride, gfc_index_zero_node);
6997 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6998 tmp, build_int_cst (gfc_array_index_type,
7001 cond = boolean_false_node;
7003 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7004 boolean_type_node, cond3, cond4);
7005 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7006 boolean_type_node, cond, cond1);
7008 return fold_build3_loc (input_location, COND_EXPR,
7009 gfc_array_index_type, cond,
7010 lbound, gfc_index_one_node);
7012 else if (expr->expr_type == EXPR_VARIABLE)
7014 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7015 for (ref = expr->ref; ref; ref = ref->next)
7017 if (ref->type == REF_COMPONENT
7018 && ref->u.c.component->as
7020 && ref->next->u.ar.type == AR_FULL)
7021 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7023 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7025 else if (expr->expr_type == EXPR_FUNCTION)
7027 /* A conversion function, so use the argument. */
7028 expr = expr->value.function.actual->expr;
7029 if (expr->expr_type != EXPR_VARIABLE)
7030 return gfc_index_one_node;
7031 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7032 return get_std_lbound (expr, desc, dim, assumed_size);
7035 return gfc_index_one_node;
7039 /* Returns true if an expression represents an lhs that can be reallocated
7043 gfc_is_reallocatable_lhs (gfc_expr *expr)
7050 /* An allocatable variable. */
7051 if (expr->symtree->n.sym->attr.allocatable
7053 && expr->ref->type == REF_ARRAY
7054 && expr->ref->u.ar.type == AR_FULL)
7057 /* All that can be left are allocatable components. */
7058 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7059 && expr->symtree->n.sym->ts.type != BT_CLASS)
7060 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7063 /* Find a component ref followed by an array reference. */
7064 for (ref = expr->ref; ref; ref = ref->next)
7066 && ref->type == REF_COMPONENT
7067 && ref->next->type == REF_ARRAY
7068 && !ref->next->next)
7074 /* Return true if valid reallocatable lhs. */
7075 if (ref->u.c.component->attr.allocatable
7076 && ref->next->u.ar.type == AR_FULL)
7083 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7087 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7091 stmtblock_t realloc_block;
7092 stmtblock_t alloc_block;
7115 gfc_array_spec * as;
7117 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7118 Find the lhs expression in the loop chain and set expr1 and
7119 expr2 accordingly. */
7120 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7123 /* Find the ss for the lhs. */
7125 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7126 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7128 if (lss == gfc_ss_terminator)
7133 /* Bail out if this is not a valid allocate on assignment. */
7134 if (!gfc_is_reallocatable_lhs (expr1)
7135 || (expr2 && !expr2->rank))
7138 /* Find the ss for the lhs. */
7140 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7141 if (lss->expr == expr1)
7144 if (lss == gfc_ss_terminator)
7147 /* Find an ss for the rhs. For operator expressions, we see the
7148 ss's for the operands. Any one of these will do. */
7150 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7151 if (rss->expr != expr1 && rss != loop->temp_ss)
7154 if (expr2 && rss == gfc_ss_terminator)
7157 gfc_start_block (&fblock);
7159 /* Since the lhs is allocatable, this must be a descriptor type.
7160 Get the data and array size. */
7161 desc = lss->data.info.descriptor;
7162 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7163 array1 = gfc_conv_descriptor_data_get (desc);
7165 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7166 deallocated if expr is an array of different shape or any of the
7167 corresponding length type parameter values of variable and expr
7168 differ." This assures F95 compatibility. */
7169 jump_label1 = gfc_build_label_decl (NULL_TREE);
7170 jump_label2 = gfc_build_label_decl (NULL_TREE);
7172 /* Allocate if data is NULL. */
7173 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7174 array1, build_int_cst (TREE_TYPE (array1), 0));
7175 tmp = build3_v (COND_EXPR, cond,
7176 build1_v (GOTO_EXPR, jump_label1),
7177 build_empty_stmt (input_location));
7178 gfc_add_expr_to_block (&fblock, tmp);
7180 /* Get arrayspec if expr is a full array. */
7181 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7182 && expr2->value.function.isym
7183 && expr2->value.function.isym->conversion)
7185 /* For conversion functions, take the arg. */
7186 gfc_expr *arg = expr2->value.function.actual->expr;
7187 as = gfc_get_full_arrayspec_from_expr (arg);
7190 as = gfc_get_full_arrayspec_from_expr (expr2);
7194 /* If the lhs shape is not the same as the rhs jump to setting the
7195 bounds and doing the reallocation....... */
7196 for (n = 0; n < expr1->rank; n++)
7198 /* Check the shape. */
7199 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7200 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7201 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7202 gfc_array_index_type,
7203 loop->to[n], loop->from[n]);
7204 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7205 gfc_array_index_type,
7207 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7208 gfc_array_index_type,
7210 cond = fold_build2_loc (input_location, NE_EXPR,
7212 tmp, gfc_index_zero_node);
7213 tmp = build3_v (COND_EXPR, cond,
7214 build1_v (GOTO_EXPR, jump_label1),
7215 build_empty_stmt (input_location));
7216 gfc_add_expr_to_block (&fblock, tmp);
7219 /* ....else jump past the (re)alloc code. */
7220 tmp = build1_v (GOTO_EXPR, jump_label2);
7221 gfc_add_expr_to_block (&fblock, tmp);
7223 /* Add the label to start automatic (re)allocation. */
7224 tmp = build1_v (LABEL_EXPR, jump_label1);
7225 gfc_add_expr_to_block (&fblock, tmp);
7227 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7229 /* Get the rhs size. Fix both sizes. */
7231 desc2 = rss->data.info.descriptor;
7234 size2 = gfc_index_one_node;
7235 for (n = 0; n < expr2->rank; n++)
7237 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7238 gfc_array_index_type,
7239 loop->to[n], loop->from[n]);
7240 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7241 gfc_array_index_type,
7242 tmp, gfc_index_one_node);
7243 size2 = fold_build2_loc (input_location, MULT_EXPR,
7244 gfc_array_index_type,
7248 size1 = gfc_evaluate_now (size1, &fblock);
7249 size2 = gfc_evaluate_now (size2, &fblock);
7251 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7253 neq_size = gfc_evaluate_now (cond, &fblock);
7256 /* Now modify the lhs descriptor and the associated scalarizer
7257 variables. F2003 7.4.1.3: "If variable is or becomes an
7258 unallocated allocatable variable, then it is allocated with each
7259 deferred type parameter equal to the corresponding type parameters
7260 of expr , with the shape of expr , and with each lower bound equal
7261 to the corresponding element of LBOUND(expr)."
7262 Reuse size1 to keep a dimension-by-dimension track of the
7263 stride of the new array. */
7264 size1 = gfc_index_one_node;
7265 offset = gfc_index_zero_node;
7267 for (n = 0; n < expr2->rank; n++)
7269 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7270 gfc_array_index_type,
7271 loop->to[n], loop->from[n]);
7272 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7273 gfc_array_index_type,
7274 tmp, gfc_index_one_node);
7276 lbound = gfc_index_one_node;
7281 lbd = get_std_lbound (expr2, desc2, n,
7282 as->type == AS_ASSUMED_SIZE);
7283 ubound = fold_build2_loc (input_location,
7285 gfc_array_index_type,
7287 ubound = fold_build2_loc (input_location,
7289 gfc_array_index_type,
7294 gfc_conv_descriptor_lbound_set (&fblock, desc,
7297 gfc_conv_descriptor_ubound_set (&fblock, desc,
7300 gfc_conv_descriptor_stride_set (&fblock, desc,
7303 lbound = gfc_conv_descriptor_lbound_get (desc,
7305 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7306 gfc_array_index_type,
7308 offset = fold_build2_loc (input_location, MINUS_EXPR,
7309 gfc_array_index_type,
7311 size1 = fold_build2_loc (input_location, MULT_EXPR,
7312 gfc_array_index_type,
7316 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7317 the array offset is saved and the info.offset is used for a
7318 running offset. Use the saved_offset instead. */
7319 tmp = gfc_conv_descriptor_offset (desc);
7320 gfc_add_modify (&fblock, tmp, offset);
7321 if (lss->data.info.saved_offset
7322 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7323 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7325 /* Now set the deltas for the lhs. */
7326 for (n = 0; n < expr1->rank; n++)
7328 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7329 dim = lss->data.info.dim[n];
7330 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7331 gfc_array_index_type, tmp,
7333 if (lss->data.info.delta[dim]
7334 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7335 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7338 /* Get the new lhs size in bytes. */
7339 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7341 tmp = expr2->ts.u.cl->backend_decl;
7342 gcc_assert (expr1->ts.u.cl->backend_decl);
7343 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7344 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7346 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7348 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7349 tmp = fold_build2_loc (input_location, MULT_EXPR,
7350 gfc_array_index_type, tmp,
7351 expr1->ts.u.cl->backend_decl);
7354 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7355 tmp = fold_convert (gfc_array_index_type, tmp);
7356 size2 = fold_build2_loc (input_location, MULT_EXPR,
7357 gfc_array_index_type,
7359 size2 = fold_convert (size_type_node, size2);
7360 size2 = gfc_evaluate_now (size2, &fblock);
7362 /* Realloc expression. Note that the scalarizer uses desc.data
7363 in the array reference - (*desc.data)[<element>]. */
7364 gfc_init_block (&realloc_block);
7365 tmp = build_call_expr_loc (input_location,
7366 built_in_decls[BUILT_IN_REALLOC], 2,
7367 fold_convert (pvoid_type_node, array1),
7369 gfc_conv_descriptor_data_set (&realloc_block,
7371 realloc_expr = gfc_finish_block (&realloc_block);
7373 /* Only reallocate if sizes are different. */
7374 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7375 build_empty_stmt (input_location));
7379 /* Malloc expression. */
7380 gfc_init_block (&alloc_block);
7381 tmp = build_call_expr_loc (input_location,
7382 built_in_decls[BUILT_IN_MALLOC], 1,
7384 gfc_conv_descriptor_data_set (&alloc_block,
7386 tmp = gfc_conv_descriptor_dtype (desc);
7387 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7388 alloc_expr = gfc_finish_block (&alloc_block);
7390 /* Malloc if not allocated; realloc otherwise. */
7391 tmp = build_int_cst (TREE_TYPE (array1), 0);
7392 cond = fold_build2_loc (input_location, EQ_EXPR,
7395 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7396 gfc_add_expr_to_block (&fblock, tmp);
7398 /* Make sure that the scalarizer data pointer is updated. */
7399 if (lss->data.info.data
7400 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7402 tmp = gfc_conv_descriptor_data_get (desc);
7403 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7406 /* Add the exit label. */
7407 tmp = build1_v (LABEL_EXPR, jump_label2);
7408 gfc_add_expr_to_block (&fblock, tmp);
7410 return gfc_finish_block (&fblock);
7414 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7415 Do likewise, recursively if necessary, with the allocatable components of
7419 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7425 stmtblock_t cleanup;
7428 bool sym_has_alloc_comp;
7430 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7431 || sym->ts.type == BT_CLASS)
7432 && sym->ts.u.derived->attr.alloc_comp;
7434 /* Make sure the frontend gets these right. */
7435 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7436 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7437 "allocatable attribute or derived type without allocatable "
7440 gfc_save_backend_locus (&loc);
7441 gfc_set_backend_locus (&sym->declared_at);
7442 gfc_init_block (&init);
7444 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7445 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7447 if (sym->ts.type == BT_CHARACTER
7448 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7450 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7451 gfc_trans_vla_type_sizes (sym, &init);
7454 /* Dummy, use associated and result variables don't need anything special. */
7455 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7457 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7458 gfc_restore_backend_locus (&loc);
7462 descriptor = sym->backend_decl;
7464 /* Although static, derived types with default initializers and
7465 allocatable components must not be nulled wholesale; instead they
7466 are treated component by component. */
7467 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7469 /* SAVEd variables are not freed on exit. */
7470 gfc_trans_static_array_pointer (sym);
7472 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7473 gfc_restore_backend_locus (&loc);
7477 /* Get the descriptor type. */
7478 type = TREE_TYPE (sym->backend_decl);
7480 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7483 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7485 if (sym->value == NULL
7486 || !gfc_has_default_initializer (sym->ts.u.derived))
7488 rank = sym->as ? sym->as->rank : 0;
7489 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7491 gfc_add_expr_to_block (&init, tmp);
7494 gfc_init_default_dt (sym, &init, false);
7497 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7499 /* If the backend_decl is not a descriptor, we must have a pointer
7501 descriptor = build_fold_indirect_ref_loc (input_location,
7503 type = TREE_TYPE (descriptor);
7506 /* NULLIFY the data pointer. */
7507 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7508 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7510 gfc_restore_backend_locus (&loc);
7511 gfc_init_block (&cleanup);
7513 /* Allocatable arrays need to be freed when they go out of scope.
7514 The allocatable components of pointers must not be touched. */
7515 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7516 && !sym->attr.pointer && !sym->attr.save)
7519 rank = sym->as ? sym->as->rank : 0;
7520 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7521 gfc_add_expr_to_block (&cleanup, tmp);
7524 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7525 && !sym->attr.save && !sym->attr.result)
7527 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7528 gfc_add_expr_to_block (&cleanup, tmp);
7531 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7532 gfc_finish_block (&cleanup));
7535 /************ Expression Walking Functions ******************/
7537 /* Walk a variable reference.
7539 Possible extension - multiple component subscripts.
7540 x(:,:) = foo%a(:)%b(:)
7542 forall (i=..., j=...)
7543 x(i,j) = foo%a(j)%b(i)
7545 This adds a fair amount of complexity because you need to deal with more
7546 than one ref. Maybe handle in a similar manner to vector subscripts.
7547 Maybe not worth the effort. */
7551 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7558 for (ref = expr->ref; ref; ref = ref->next)
7559 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7562 for (; ref; ref = ref->next)
7564 if (ref->type == REF_SUBSTRING)
7566 newss = gfc_get_ss ();
7567 newss->type = GFC_SS_SCALAR;
7568 newss->expr = ref->u.ss.start;
7572 newss = gfc_get_ss ();
7573 newss->type = GFC_SS_SCALAR;
7574 newss->expr = ref->u.ss.end;
7579 /* We're only interested in array sections from now on. */
7580 if (ref->type != REF_ARRAY)
7585 if (ar->as->rank == 0 && ref->next != NULL)
7587 /* Scalar coarray. */
7594 for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
7596 newss = gfc_get_ss ();
7597 newss->type = GFC_SS_SCALAR;
7598 newss->expr = ar->start[n];
7605 newss = gfc_get_ss ();
7606 newss->type = GFC_SS_SECTION;
7609 newss->data.info.dimen = ar->as->rank;
7610 newss->data.info.codimen = 0;
7611 newss->data.info.ref = ref;
7613 /* Make sure array is the same as array(:,:), this way
7614 we don't need to special case all the time. */
7615 ar->dimen = ar->as->rank;
7617 for (n = 0; n < ar->dimen; n++)
7619 newss->data.info.dim[n] = n;
7620 ar->dimen_type[n] = DIMEN_RANGE;
7622 gcc_assert (ar->start[n] == NULL);
7623 gcc_assert (ar->end[n] == NULL);
7624 gcc_assert (ar->stride[n] == NULL);
7626 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7628 newss->data.info.dim[n] = n;
7629 ar->dimen_type[n] = DIMEN_RANGE;
7631 gcc_assert (ar->start[n] == NULL);
7632 gcc_assert (ar->end[n] == NULL);
7638 newss = gfc_get_ss ();
7639 newss->type = GFC_SS_SECTION;
7642 newss->data.info.dimen = 0;
7643 newss->data.info.codimen = 0;
7644 newss->data.info.ref = ref;
7646 /* We add SS chains for all the subscripts in the section. */
7647 for (n = 0; n < ar->dimen + ar->codimen; n++)
7651 switch (ar->dimen_type[n])
7653 case DIMEN_THIS_IMAGE:
7656 /* Add SS for elemental (scalar) subscripts. */
7657 gcc_assert (ar->start[n]);
7658 indexss = gfc_get_ss ();
7659 indexss->type = GFC_SS_SCALAR;
7660 indexss->expr = ar->start[n];
7661 indexss->next = gfc_ss_terminator;
7662 indexss->loop_chain = gfc_ss_terminator;
7663 newss->data.info.subscript[n] = indexss;
7667 /* We don't add anything for sections, just remember this
7668 dimension for later. */
7669 newss->data.info.dim[newss->data.info.dimen
7670 + newss->data.info.codimen] = n;
7672 newss->data.info.dimen++;
7676 /* Create a GFC_SS_VECTOR index in which we can store
7677 the vector's descriptor. */
7678 indexss = gfc_get_ss ();
7679 indexss->type = GFC_SS_VECTOR;
7680 indexss->expr = ar->start[n];
7681 indexss->next = gfc_ss_terminator;
7682 indexss->loop_chain = gfc_ss_terminator;
7683 newss->data.info.subscript[n] = indexss;
7684 newss->data.info.dim[newss->data.info.dimen
7685 + newss->data.info.codimen] = n;
7687 newss->data.info.dimen++;
7691 /* We should know what sort of section it is by now. */
7695 /* We should have at least one non-elemental dimension. */
7696 gcc_assert (newss->data.info.dimen > 0);
7701 /* We should know what sort of section it is by now. */
7710 /* Walk an expression operator. If only one operand of a binary expression is
7711 scalar, we must also add the scalar term to the SS chain. */
7714 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7720 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7721 if (expr->value.op.op2 == NULL)
7724 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7726 /* All operands are scalar. Pass back and let the caller deal with it. */
7730 /* All operands require scalarization. */
7731 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7734 /* One of the operands needs scalarization, the other is scalar.
7735 Create a gfc_ss for the scalar expression. */
7736 newss = gfc_get_ss ();
7737 newss->type = GFC_SS_SCALAR;
7740 /* First operand is scalar. We build the chain in reverse order, so
7741 add the scalar SS after the second operand. */
7743 while (head && head->next != ss)
7745 /* Check we haven't somehow broken the chain. */
7749 newss->expr = expr->value.op.op1;
7751 else /* head2 == head */
7753 gcc_assert (head2 == head);
7754 /* Second operand is scalar. */
7755 newss->next = head2;
7757 newss->expr = expr->value.op.op2;
7764 /* Reverse a SS chain. */
7767 gfc_reverse_ss (gfc_ss * ss)
7772 gcc_assert (ss != NULL);
7774 head = gfc_ss_terminator;
7775 while (ss != gfc_ss_terminator)
7778 /* Check we didn't somehow break the chain. */
7779 gcc_assert (next != NULL);
7789 /* Walk the arguments of an elemental function. */
7792 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7800 head = gfc_ss_terminator;
7803 for (; arg; arg = arg->next)
7808 newss = gfc_walk_subexpr (head, arg->expr);
7811 /* Scalar argument. */
7812 newss = gfc_get_ss ();
7814 newss->expr = arg->expr;
7824 while (tail->next != gfc_ss_terminator)
7831 /* If all the arguments are scalar we don't need the argument SS. */
7832 gfc_free_ss_chain (head);
7837 /* Add it onto the existing chain. */
7843 /* Walk a function call. Scalar functions are passed back, and taken out of
7844 scalarization loops. For elemental functions we walk their arguments.
7845 The result of functions returning arrays is stored in a temporary outside
7846 the loop, so that the function is only called once. Hence we do not need
7847 to walk their arguments. */
7850 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7853 gfc_intrinsic_sym *isym;
7855 gfc_component *comp = NULL;
7858 isym = expr->value.function.isym;
7860 /* Handle intrinsic functions separately. */
7862 return gfc_walk_intrinsic_function (ss, expr, isym);
7864 sym = expr->value.function.esym;
7866 sym = expr->symtree->n.sym;
7868 /* A function that returns arrays. */
7869 gfc_is_proc_ptr_comp (expr, &comp);
7870 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7871 || (comp && comp->attr.dimension))
7873 newss = gfc_get_ss ();
7874 newss->type = GFC_SS_FUNCTION;
7877 newss->data.info.dimen = expr->rank;
7878 for (n = 0; n < newss->data.info.dimen; n++)
7879 newss->data.info.dim[n] = n;
7883 /* Walk the parameters of an elemental function. For now we always pass
7885 if (sym->attr.elemental)
7886 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7889 /* Scalar functions are OK as these are evaluated outside the scalarization
7890 loop. Pass back and let the caller deal with it. */
7895 /* An array temporary is constructed for array constructors. */
7898 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7903 newss = gfc_get_ss ();
7904 newss->type = GFC_SS_CONSTRUCTOR;
7907 newss->data.info.dimen = expr->rank;
7908 for (n = 0; n < expr->rank; n++)
7909 newss->data.info.dim[n] = n;
7915 /* Walk an expression. Add walked expressions to the head of the SS chain.
7916 A wholly scalar expression will not be added. */
7919 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7923 switch (expr->expr_type)
7926 head = gfc_walk_variable_expr (ss, expr);
7930 head = gfc_walk_op_expr (ss, expr);
7934 head = gfc_walk_function_expr (ss, expr);
7939 case EXPR_STRUCTURE:
7940 /* Pass back and let the caller deal with it. */
7944 head = gfc_walk_array_constructor (ss, expr);
7947 case EXPR_SUBSTRING:
7948 /* Pass back and let the caller deal with it. */
7952 internal_error ("bad expression type during walk (%d)",
7959 /* Entry point for expression walking.
7960 A return value equal to the passed chain means this is
7961 a scalar expression. It is up to the caller to take whatever action is
7962 necessary to translate these. */
7965 gfc_walk_expr (gfc_expr * expr)
7969 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7970 return gfc_reverse_ss (res);