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_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
281 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
282 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
285 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
286 desc, field, NULL_TREE);
291 gfc_conv_descriptor_stride (tree desc, tree dim)
296 tmp = gfc_conv_descriptor_dimension (desc, dim);
297 field = TYPE_FIELDS (TREE_TYPE (tmp));
298 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
299 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
301 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
302 tmp, field, NULL_TREE);
307 gfc_conv_descriptor_stride_get (tree desc, tree dim)
309 tree type = TREE_TYPE (desc);
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 if (integer_zerop (dim)
312 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
313 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
314 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
315 return gfc_index_one_node;
317 return gfc_conv_descriptor_stride (desc, dim);
321 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
322 tree dim, tree value)
324 tree t = gfc_conv_descriptor_stride (desc, dim);
325 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
329 gfc_conv_descriptor_lbound (tree desc, tree dim)
334 tmp = gfc_conv_descriptor_dimension (desc, dim);
335 field = TYPE_FIELDS (TREE_TYPE (tmp));
336 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
337 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
339 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
340 tmp, field, NULL_TREE);
345 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
347 return gfc_conv_descriptor_lbound (desc, dim);
351 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
352 tree dim, tree value)
354 tree t = gfc_conv_descriptor_lbound (desc, dim);
355 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
359 gfc_conv_descriptor_ubound (tree desc, tree dim)
364 tmp = gfc_conv_descriptor_dimension (desc, dim);
365 field = TYPE_FIELDS (TREE_TYPE (tmp));
366 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
367 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
369 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
370 tmp, field, NULL_TREE);
375 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
377 return gfc_conv_descriptor_ubound (desc, dim);
381 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
382 tree dim, tree value)
384 tree t = gfc_conv_descriptor_ubound (desc, dim);
385 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
388 /* Build a null array descriptor constructor. */
391 gfc_build_null_descriptor (tree type)
396 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
397 gcc_assert (DATA_FIELD == 0);
398 field = TYPE_FIELDS (type);
400 /* Set a NULL data pointer. */
401 tmp = build_constructor_single (type, field, null_pointer_node);
402 TREE_CONSTANT (tmp) = 1;
403 /* All other fields are ignored. */
409 /* Modify a descriptor such that the lbound of a given dimension is the value
410 specified. This also updates ubound and offset accordingly. */
413 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
414 int dim, tree new_lbound)
416 tree offs, ubound, lbound, stride;
417 tree diff, offs_diff;
419 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
421 offs = gfc_conv_descriptor_offset_get (desc);
422 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
423 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
424 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
426 /* Get difference (new - old) by which to shift stuff. */
427 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
430 /* Shift ubound and offset accordingly. This has to be done before
431 updating the lbound, as they depend on the lbound expression! */
432 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
434 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
435 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
437 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
439 gfc_conv_descriptor_offset_set (block, desc, offs);
441 /* Finally set lbound to value we want. */
442 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
446 /* Cleanup those #defines. */
451 #undef DIMENSION_FIELD
452 #undef CAF_TOKEN_FIELD
453 #undef STRIDE_SUBFIELD
454 #undef LBOUND_SUBFIELD
455 #undef UBOUND_SUBFIELD
458 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
459 flags & 1 = Main loop body.
460 flags & 2 = temp copy loop. */
463 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
465 for (; ss != gfc_ss_terminator; ss = ss->next)
466 ss->useflags = flags;
469 static void gfc_free_ss (gfc_ss *);
472 /* Free a gfc_ss chain. */
475 gfc_free_ss_chain (gfc_ss * ss)
479 while (ss != gfc_ss_terminator)
481 gcc_assert (ss != NULL);
492 gfc_free_ss (gfc_ss * ss)
499 for (n = 0; n < ss->data.info.dimen; n++)
501 if (ss->data.info.subscript[ss->data.info.dim[n]])
502 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
514 /* Creates and initializes an array type gfc_ss struct. */
517 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
527 info = &ss->data.info;
529 for (i = 0; i < info->dimen; i++)
536 /* Creates and initializes a temporary type gfc_ss struct. */
539 gfc_get_temp_ss (tree type, tree string_length, int dimen)
544 ss->next = gfc_ss_terminator;
545 ss->type = GFC_SS_TEMP;
546 ss->string_length = string_length;
547 ss->data.temp.dimen = dimen;
548 ss->data.temp.type = type;
554 /* Creates and initializes a scalar type gfc_ss struct. */
557 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
563 ss->type = GFC_SS_SCALAR;
570 /* Free all the SS associated with a loop. */
573 gfc_cleanup_loop (gfc_loopinfo * loop)
579 while (ss != gfc_ss_terminator)
581 gcc_assert (ss != NULL);
582 next = ss->loop_chain;
589 /* Associate a SS chain with a loop. */
592 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
596 if (head == gfc_ss_terminator)
600 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
602 if (ss->next == gfc_ss_terminator)
603 ss->loop_chain = loop->ss;
605 ss->loop_chain = ss->next;
607 gcc_assert (ss == gfc_ss_terminator);
612 /* Generate an initializer for a static pointer or allocatable array. */
615 gfc_trans_static_array_pointer (gfc_symbol * sym)
619 gcc_assert (TREE_STATIC (sym->backend_decl));
620 /* Just zero the data member. */
621 type = TREE_TYPE (sym->backend_decl);
622 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
626 /* If the bounds of SE's loop have not yet been set, see if they can be
627 determined from array spec AS, which is the array spec of a called
628 function. MAPPING maps the callee's dummy arguments to the values
629 that the caller is passing. Add any initialization and finalization
633 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
634 gfc_se * se, gfc_array_spec * as)
642 if (as && as->type == AS_EXPLICIT)
643 for (n = 0; n < se->loop->dimen; n++)
645 dim = se->ss->data.info.dim[n];
646 gcc_assert (dim < as->rank);
647 gcc_assert (se->loop->dimen == as->rank);
648 if (se->loop->to[n] == NULL_TREE)
650 /* Evaluate the lower bound. */
651 gfc_init_se (&tmpse, NULL);
652 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
653 gfc_add_block_to_block (&se->pre, &tmpse.pre);
654 gfc_add_block_to_block (&se->post, &tmpse.post);
655 lower = fold_convert (gfc_array_index_type, tmpse.expr);
657 /* ...and the upper bound. */
658 gfc_init_se (&tmpse, NULL);
659 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
660 gfc_add_block_to_block (&se->pre, &tmpse.pre);
661 gfc_add_block_to_block (&se->post, &tmpse.post);
662 upper = fold_convert (gfc_array_index_type, tmpse.expr);
664 /* Set the upper bound of the loop to UPPER - LOWER. */
665 tmp = fold_build2_loc (input_location, MINUS_EXPR,
666 gfc_array_index_type, upper, lower);
667 tmp = gfc_evaluate_now (tmp, &se->pre);
668 se->loop->to[n] = tmp;
674 /* Generate code to allocate an array temporary, or create a variable to
675 hold the data. If size is NULL, zero the descriptor so that the
676 callee will allocate the array. If DEALLOC is true, also generate code to
677 free the array afterwards.
679 If INITIAL is not NULL, it is packed using internal_pack and the result used
680 as data instead of allocating a fresh, unitialized area of memory.
682 Initialization code is added to PRE and finalization code to POST.
683 DYNAMIC is true if the caller may want to extend the array later
684 using realloc. This prevents us from putting the array on the stack. */
687 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
688 gfc_ss_info * info, tree size, tree nelem,
689 tree initial, bool dynamic, bool dealloc)
695 desc = info->descriptor;
696 info->offset = gfc_index_zero_node;
697 if (size == NULL_TREE || integer_zerop (size))
699 /* A callee allocated array. */
700 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
705 /* Allocate the temporary. */
706 onstack = !dynamic && initial == NULL_TREE
707 && (gfc_option.flag_stack_arrays
708 || gfc_can_put_var_on_stack (size));
712 /* Make a temporary variable to hold the data. */
713 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
714 nelem, gfc_index_one_node);
715 tmp = gfc_evaluate_now (tmp, pre);
716 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
718 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
720 tmp = gfc_create_var (tmp, "A");
721 /* If we're here only because of -fstack-arrays we have to
722 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
723 if (!gfc_can_put_var_on_stack (size))
724 gfc_add_expr_to_block (pre,
725 fold_build1_loc (input_location,
726 DECL_EXPR, TREE_TYPE (tmp),
728 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
729 gfc_conv_descriptor_data_set (pre, desc, tmp);
733 /* Allocate memory to hold the data or call internal_pack. */
734 if (initial == NULL_TREE)
736 tmp = gfc_call_malloc (pre, NULL, size);
737 tmp = gfc_evaluate_now (tmp, pre);
744 stmtblock_t do_copying;
746 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
747 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
748 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
749 tmp = gfc_get_element_type (tmp);
750 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
751 packed = gfc_create_var (build_pointer_type (tmp), "data");
753 tmp = build_call_expr_loc (input_location,
754 gfor_fndecl_in_pack, 1, initial);
755 tmp = fold_convert (TREE_TYPE (packed), tmp);
756 gfc_add_modify (pre, packed, tmp);
758 tmp = build_fold_indirect_ref_loc (input_location,
760 source_data = gfc_conv_descriptor_data_get (tmp);
762 /* internal_pack may return source->data without any allocation
763 or copying if it is already packed. If that's the case, we
764 need to allocate and copy manually. */
766 gfc_start_block (&do_copying);
767 tmp = gfc_call_malloc (&do_copying, NULL, size);
768 tmp = fold_convert (TREE_TYPE (packed), tmp);
769 gfc_add_modify (&do_copying, packed, tmp);
770 tmp = gfc_build_memcpy_call (packed, source_data, size);
771 gfc_add_expr_to_block (&do_copying, tmp);
773 was_packed = fold_build2_loc (input_location, EQ_EXPR,
774 boolean_type_node, packed,
776 tmp = gfc_finish_block (&do_copying);
777 tmp = build3_v (COND_EXPR, was_packed, tmp,
778 build_empty_stmt (input_location));
779 gfc_add_expr_to_block (pre, tmp);
781 tmp = fold_convert (pvoid_type_node, packed);
784 gfc_conv_descriptor_data_set (pre, desc, tmp);
787 info->data = gfc_conv_descriptor_data_get (desc);
789 /* The offset is zero because we create temporaries with a zero
791 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
793 if (dealloc && !onstack)
795 /* Free the temporary. */
796 tmp = gfc_conv_descriptor_data_get (desc);
797 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
798 gfc_add_expr_to_block (post, tmp);
803 /* Get the array reference dimension corresponding to the given loop dimension.
804 It is different from the true array dimension given by the dim array in
805 the case of a partial array reference
806 It is different from the loop dimension in the case of a transposed array.
810 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
812 int n, array_dim, array_ref_dim;
815 array_dim = info->dim[loop_dim];
817 for (n = 0; n < info->dimen; n++)
818 if (info->dim[n] < array_dim)
821 return array_ref_dim;
825 /* Generate code to create and initialize the descriptor for a temporary
826 array. This is used for both temporaries needed by the scalarizer, and
827 functions returning arrays. Adjusts the loop variables to be
828 zero-based, and calculates the loop bounds for callee allocated arrays.
829 Allocate the array unless it's callee allocated (we have a callee
830 allocated array if 'callee_alloc' is true, or if loop->to[n] is
831 NULL_TREE for any n). Also fills in the descriptor, data and offset
832 fields of info if known. Returns the size of the array, or NULL for a
833 callee allocated array.
835 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
836 gfc_trans_allocate_array_storage.
840 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
841 gfc_loopinfo * loop, gfc_ss_info * info,
842 tree eltype, tree initial, bool dynamic,
843 bool dealloc, bool callee_alloc, locus * where)
845 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
855 memset (from, 0, sizeof (from));
856 memset (to, 0, sizeof (to));
858 gcc_assert (info->dimen > 0);
859 gcc_assert (loop->dimen == info->dimen);
861 if (gfc_option.warn_array_temp && where)
862 gfc_warning ("Creating array temporary at %L", where);
864 /* Set the lower bound to zero. */
865 for (n = 0; n < loop->dimen; n++)
869 /* Callee allocated arrays may not have a known bound yet. */
871 loop->to[n] = gfc_evaluate_now (
872 fold_build2_loc (input_location, MINUS_EXPR,
873 gfc_array_index_type,
874 loop->to[n], loop->from[n]),
876 loop->from[n] = gfc_index_zero_node;
878 /* We are constructing the temporary's descriptor based on the loop
879 dimensions. As the dimensions may be accessed in arbitrary order
880 (think of transpose) the size taken from the n'th loop may not map
881 to the n'th dimension of the array. We need to reconstruct loop infos
882 in the right order before using it to set the descriptor
884 tmp_dim = get_array_ref_dim (info, n);
885 from[tmp_dim] = loop->from[n];
886 to[tmp_dim] = loop->to[n];
888 info->delta[dim] = gfc_index_zero_node;
889 info->start[dim] = gfc_index_zero_node;
890 info->end[dim] = gfc_index_zero_node;
891 info->stride[dim] = gfc_index_one_node;
894 /* Initialize the descriptor. */
896 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
897 GFC_ARRAY_UNKNOWN, true);
898 desc = gfc_create_var (type, "atmp");
899 GFC_DECL_PACKED_ARRAY (desc) = 1;
901 info->descriptor = desc;
902 size = gfc_index_one_node;
904 /* Fill in the array dtype. */
905 tmp = gfc_conv_descriptor_dtype (desc);
906 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
909 Fill in the bounds and stride. This is a packed array, so:
912 for (n = 0; n < rank; n++)
915 delta = ubound[n] + 1 - lbound[n];
918 size = size * sizeof(element);
923 /* If there is at least one null loop->to[n], it is a callee allocated
925 for (n = 0; n < loop->dimen; n++)
926 if (loop->to[n] == NULL_TREE)
932 for (n = 0; n < loop->dimen; n++)
936 if (size == NULL_TREE)
938 /* For a callee allocated array express the loop bounds in terms
939 of the descriptor fields. */
940 tmp = fold_build2_loc (input_location,
941 MINUS_EXPR, gfc_array_index_type,
942 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
943 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
948 /* Store the stride and bound components in the descriptor. */
949 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
951 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
952 gfc_index_zero_node);
954 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
957 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
958 to[n], gfc_index_one_node);
960 /* Check whether the size for this dimension is negative. */
961 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
962 gfc_index_zero_node);
963 cond = gfc_evaluate_now (cond, pre);
968 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
969 boolean_type_node, or_expr, cond);
971 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
973 size = gfc_evaluate_now (size, pre);
976 /* Get the size of the array. */
978 if (size && !callee_alloc)
980 /* If or_expr is true, then the extent in at least one
981 dimension is zero and the size is set to zero. */
982 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
983 or_expr, gfc_index_zero_node, size);
986 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
988 fold_convert (gfc_array_index_type,
989 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
997 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1000 if (info->dimen > loop->temp_dim)
1001 loop->temp_dim = info->dimen;
1007 /* Return the number of iterations in a loop that starts at START,
1008 ends at END, and has step STEP. */
1011 gfc_get_iteration_count (tree start, tree end, tree step)
1016 type = TREE_TYPE (step);
1017 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1018 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1019 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1020 build_int_cst (type, 1));
1021 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1022 build_int_cst (type, 0));
1023 return fold_convert (gfc_array_index_type, tmp);
1027 /* Extend the data in array DESC by EXTRA elements. */
1030 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1037 if (integer_zerop (extra))
1040 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1042 /* Add EXTRA to the upper bound. */
1043 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1045 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1047 /* Get the value of the current data pointer. */
1048 arg0 = gfc_conv_descriptor_data_get (desc);
1050 /* Calculate the new array size. */
1051 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1052 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1053 ubound, gfc_index_one_node);
1054 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1055 fold_convert (size_type_node, tmp),
1056 fold_convert (size_type_node, size));
1058 /* Call the realloc() function. */
1059 tmp = gfc_call_realloc (pblock, arg0, arg1);
1060 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1064 /* Return true if the bounds of iterator I can only be determined
1068 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1070 return (i->start->expr_type != EXPR_CONSTANT
1071 || i->end->expr_type != EXPR_CONSTANT
1072 || i->step->expr_type != EXPR_CONSTANT);
1076 /* Split the size of constructor element EXPR into the sum of two terms,
1077 one of which can be determined at compile time and one of which must
1078 be calculated at run time. Set *SIZE to the former and return true
1079 if the latter might be nonzero. */
1082 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1084 if (expr->expr_type == EXPR_ARRAY)
1085 return gfc_get_array_constructor_size (size, expr->value.constructor);
1086 else if (expr->rank > 0)
1088 /* Calculate everything at run time. */
1089 mpz_set_ui (*size, 0);
1094 /* A single element. */
1095 mpz_set_ui (*size, 1);
1101 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1102 of array constructor C. */
1105 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1113 mpz_set_ui (*size, 0);
1118 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1121 if (i && gfc_iterator_has_dynamic_bounds (i))
1125 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1128 /* Multiply the static part of the element size by the
1129 number of iterations. */
1130 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1131 mpz_fdiv_q (val, val, i->step->value.integer);
1132 mpz_add_ui (val, val, 1);
1133 if (mpz_sgn (val) > 0)
1134 mpz_mul (len, len, val);
1136 mpz_set_ui (len, 0);
1138 mpz_add (*size, *size, len);
1147 /* Make sure offset is a variable. */
1150 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1153 /* We should have already created the offset variable. We cannot
1154 create it here because we may be in an inner scope. */
1155 gcc_assert (*offsetvar != NULL_TREE);
1156 gfc_add_modify (pblock, *offsetvar, *poffset);
1157 *poffset = *offsetvar;
1158 TREE_USED (*offsetvar) = 1;
1162 /* Variables needed for bounds-checking. */
1163 static bool first_len;
1164 static tree first_len_val;
1165 static bool typespec_chararray_ctor;
1168 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1169 tree offset, gfc_se * se, gfc_expr * expr)
1173 gfc_conv_expr (se, expr);
1175 /* Store the value. */
1176 tmp = build_fold_indirect_ref_loc (input_location,
1177 gfc_conv_descriptor_data_get (desc));
1178 tmp = gfc_build_array_ref (tmp, offset, NULL);
1180 if (expr->ts.type == BT_CHARACTER)
1182 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1185 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1186 esize = fold_convert (gfc_charlen_type_node, esize);
1187 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1188 gfc_charlen_type_node, esize,
1189 build_int_cst (gfc_charlen_type_node,
1190 gfc_character_kinds[i].bit_size / 8));
1192 gfc_conv_string_parameter (se);
1193 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1195 /* The temporary is an array of pointers. */
1196 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1197 gfc_add_modify (&se->pre, tmp, se->expr);
1201 /* The temporary is an array of string values. */
1202 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1203 /* We know the temporary and the value will be the same length,
1204 so can use memcpy. */
1205 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1206 se->string_length, se->expr, expr->ts.kind);
1208 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1212 gfc_add_modify (&se->pre, first_len_val,
1218 /* Verify that all constructor elements are of the same
1220 tree cond = fold_build2_loc (input_location, NE_EXPR,
1221 boolean_type_node, first_len_val,
1223 gfc_trans_runtime_check
1224 (true, false, cond, &se->pre, &expr->where,
1225 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1226 fold_convert (long_integer_type_node, first_len_val),
1227 fold_convert (long_integer_type_node, se->string_length));
1233 /* TODO: Should the frontend already have done this conversion? */
1234 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1235 gfc_add_modify (&se->pre, tmp, se->expr);
1238 gfc_add_block_to_block (pblock, &se->pre);
1239 gfc_add_block_to_block (pblock, &se->post);
1243 /* Add the contents of an array to the constructor. DYNAMIC is as for
1244 gfc_trans_array_constructor_value. */
1247 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1248 tree type ATTRIBUTE_UNUSED,
1249 tree desc, gfc_expr * expr,
1250 tree * poffset, tree * offsetvar,
1261 /* We need this to be a variable so we can increment it. */
1262 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1264 gfc_init_se (&se, NULL);
1266 /* Walk the array expression. */
1267 ss = gfc_walk_expr (expr);
1268 gcc_assert (ss != gfc_ss_terminator);
1270 /* Initialize the scalarizer. */
1271 gfc_init_loopinfo (&loop);
1272 gfc_add_ss_to_loop (&loop, ss);
1274 /* Initialize the loop. */
1275 gfc_conv_ss_startstride (&loop);
1276 gfc_conv_loop_setup (&loop, &expr->where);
1278 /* Make sure the constructed array has room for the new data. */
1281 /* Set SIZE to the total number of elements in the subarray. */
1282 size = gfc_index_one_node;
1283 for (n = 0; n < loop.dimen; n++)
1285 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1286 gfc_index_one_node);
1287 size = fold_build2_loc (input_location, MULT_EXPR,
1288 gfc_array_index_type, size, tmp);
1291 /* Grow the constructed array by SIZE elements. */
1292 gfc_grow_array (&loop.pre, desc, size);
1295 /* Make the loop body. */
1296 gfc_mark_ss_chain_used (ss, 1);
1297 gfc_start_scalarized_body (&loop, &body);
1298 gfc_copy_loopinfo_to_se (&se, &loop);
1301 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1302 gcc_assert (se.ss == gfc_ss_terminator);
1304 /* Increment the offset. */
1305 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1306 *poffset, gfc_index_one_node);
1307 gfc_add_modify (&body, *poffset, tmp);
1309 /* Finish the loop. */
1310 gfc_trans_scalarizing_loops (&loop, &body);
1311 gfc_add_block_to_block (&loop.pre, &loop.post);
1312 tmp = gfc_finish_block (&loop.pre);
1313 gfc_add_expr_to_block (pblock, tmp);
1315 gfc_cleanup_loop (&loop);
1319 /* Assign the values to the elements of an array constructor. DYNAMIC
1320 is true if descriptor DESC only contains enough data for the static
1321 size calculated by gfc_get_array_constructor_size. When true, memory
1322 for the dynamic parts must be allocated using realloc. */
1325 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1326 tree desc, gfc_constructor_base base,
1327 tree * poffset, tree * offsetvar,
1336 tree shadow_loopvar = NULL_TREE;
1337 gfc_saved_var saved_loopvar;
1340 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1342 /* If this is an iterator or an array, the offset must be a variable. */
1343 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1344 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1346 /* Shadowing the iterator avoids changing its value and saves us from
1347 keeping track of it. Further, it makes sure that there's always a
1348 backend-decl for the symbol, even if there wasn't one before,
1349 e.g. in the case of an iterator that appears in a specification
1350 expression in an interface mapping. */
1353 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1354 tree type = gfc_typenode_for_spec (&sym->ts);
1356 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1357 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1360 gfc_start_block (&body);
1362 if (c->expr->expr_type == EXPR_ARRAY)
1364 /* Array constructors can be nested. */
1365 gfc_trans_array_constructor_value (&body, type, desc,
1366 c->expr->value.constructor,
1367 poffset, offsetvar, dynamic);
1369 else if (c->expr->rank > 0)
1371 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1372 poffset, offsetvar, dynamic);
1376 /* This code really upsets the gimplifier so don't bother for now. */
1383 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1385 p = gfc_constructor_next (p);
1390 /* Scalar values. */
1391 gfc_init_se (&se, NULL);
1392 gfc_trans_array_ctor_element (&body, desc, *poffset,
1395 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1396 gfc_array_index_type,
1397 *poffset, gfc_index_one_node);
1401 /* Collect multiple scalar constants into a constructor. */
1402 VEC(constructor_elt,gc) *v = NULL;
1406 HOST_WIDE_INT idx = 0;
1409 /* Count the number of consecutive scalar constants. */
1410 while (p && !(p->iterator
1411 || p->expr->expr_type != EXPR_CONSTANT))
1413 gfc_init_se (&se, NULL);
1414 gfc_conv_constant (&se, p->expr);
1416 if (c->expr->ts.type != BT_CHARACTER)
1417 se.expr = fold_convert (type, se.expr);
1418 /* For constant character array constructors we build
1419 an array of pointers. */
1420 else if (POINTER_TYPE_P (type))
1421 se.expr = gfc_build_addr_expr
1422 (gfc_get_pchar_type (p->expr->ts.kind),
1425 CONSTRUCTOR_APPEND_ELT (v,
1426 build_int_cst (gfc_array_index_type,
1430 p = gfc_constructor_next (p);
1433 bound = size_int (n - 1);
1434 /* Create an array type to hold them. */
1435 tmptype = build_range_type (gfc_array_index_type,
1436 gfc_index_zero_node, bound);
1437 tmptype = build_array_type (type, tmptype);
1439 init = build_constructor (tmptype, v);
1440 TREE_CONSTANT (init) = 1;
1441 TREE_STATIC (init) = 1;
1442 /* Create a static variable to hold the data. */
1443 tmp = gfc_create_var (tmptype, "data");
1444 TREE_STATIC (tmp) = 1;
1445 TREE_CONSTANT (tmp) = 1;
1446 TREE_READONLY (tmp) = 1;
1447 DECL_INITIAL (tmp) = init;
1450 /* Use BUILTIN_MEMCPY to assign the values. */
1451 tmp = gfc_conv_descriptor_data_get (desc);
1452 tmp = build_fold_indirect_ref_loc (input_location,
1454 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1455 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1456 init = gfc_build_addr_expr (NULL_TREE, init);
1458 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1459 bound = build_int_cst (size_type_node, n * size);
1460 tmp = build_call_expr_loc (input_location,
1461 builtin_decl_explicit (BUILT_IN_MEMCPY),
1462 3, tmp, init, bound);
1463 gfc_add_expr_to_block (&body, tmp);
1465 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1466 gfc_array_index_type, *poffset,
1467 build_int_cst (gfc_array_index_type, n));
1469 if (!INTEGER_CST_P (*poffset))
1471 gfc_add_modify (&body, *offsetvar, *poffset);
1472 *poffset = *offsetvar;
1476 /* The frontend should already have done any expansions
1480 /* Pass the code as is. */
1481 tmp = gfc_finish_block (&body);
1482 gfc_add_expr_to_block (pblock, tmp);
1486 /* Build the implied do-loop. */
1487 stmtblock_t implied_do_block;
1495 loopbody = gfc_finish_block (&body);
1497 /* Create a new block that holds the implied-do loop. A temporary
1498 loop-variable is used. */
1499 gfc_start_block(&implied_do_block);
1501 /* Initialize the loop. */
1502 gfc_init_se (&se, NULL);
1503 gfc_conv_expr_val (&se, c->iterator->start);
1504 gfc_add_block_to_block (&implied_do_block, &se.pre);
1505 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1507 gfc_init_se (&se, NULL);
1508 gfc_conv_expr_val (&se, c->iterator->end);
1509 gfc_add_block_to_block (&implied_do_block, &se.pre);
1510 end = gfc_evaluate_now (se.expr, &implied_do_block);
1512 gfc_init_se (&se, NULL);
1513 gfc_conv_expr_val (&se, c->iterator->step);
1514 gfc_add_block_to_block (&implied_do_block, &se.pre);
1515 step = gfc_evaluate_now (se.expr, &implied_do_block);
1517 /* If this array expands dynamically, and the number of iterations
1518 is not constant, we won't have allocated space for the static
1519 part of C->EXPR's size. Do that now. */
1520 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1522 /* Get the number of iterations. */
1523 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1525 /* Get the static part of C->EXPR's size. */
1526 gfc_get_array_constructor_element_size (&size, c->expr);
1527 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1529 /* Grow the array by TMP * TMP2 elements. */
1530 tmp = fold_build2_loc (input_location, MULT_EXPR,
1531 gfc_array_index_type, tmp, tmp2);
1532 gfc_grow_array (&implied_do_block, desc, tmp);
1535 /* Generate the loop body. */
1536 exit_label = gfc_build_label_decl (NULL_TREE);
1537 gfc_start_block (&body);
1539 /* Generate the exit condition. Depending on the sign of
1540 the step variable we have to generate the correct
1542 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1543 step, build_int_cst (TREE_TYPE (step), 0));
1544 cond = fold_build3_loc (input_location, COND_EXPR,
1545 boolean_type_node, tmp,
1546 fold_build2_loc (input_location, GT_EXPR,
1547 boolean_type_node, shadow_loopvar, end),
1548 fold_build2_loc (input_location, LT_EXPR,
1549 boolean_type_node, shadow_loopvar, end));
1550 tmp = build1_v (GOTO_EXPR, exit_label);
1551 TREE_USED (exit_label) = 1;
1552 tmp = build3_v (COND_EXPR, cond, tmp,
1553 build_empty_stmt (input_location));
1554 gfc_add_expr_to_block (&body, tmp);
1556 /* The main loop body. */
1557 gfc_add_expr_to_block (&body, loopbody);
1559 /* Increase loop variable by step. */
1560 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1561 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1563 gfc_add_modify (&body, shadow_loopvar, tmp);
1565 /* Finish the loop. */
1566 tmp = gfc_finish_block (&body);
1567 tmp = build1_v (LOOP_EXPR, tmp);
1568 gfc_add_expr_to_block (&implied_do_block, tmp);
1570 /* Add the exit label. */
1571 tmp = build1_v (LABEL_EXPR, exit_label);
1572 gfc_add_expr_to_block (&implied_do_block, tmp);
1574 /* Finishe the implied-do loop. */
1575 tmp = gfc_finish_block(&implied_do_block);
1576 gfc_add_expr_to_block(pblock, tmp);
1578 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1585 /* A catch-all to obtain the string length for anything that is not a
1586 a substring of non-constant length, a constant, array or variable. */
1589 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1594 /* Don't bother if we already know the length is a constant. */
1595 if (*len && INTEGER_CST_P (*len))
1598 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1599 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1602 gfc_conv_const_charlen (e->ts.u.cl);
1603 *len = e->ts.u.cl->backend_decl;
1607 /* Otherwise, be brutal even if inefficient. */
1608 ss = gfc_walk_expr (e);
1609 gfc_init_se (&se, NULL);
1611 /* No function call, in case of side effects. */
1612 se.no_function_call = 1;
1613 if (ss == gfc_ss_terminator)
1614 gfc_conv_expr (&se, e);
1616 gfc_conv_expr_descriptor (&se, e, ss);
1618 /* Fix the value. */
1619 *len = gfc_evaluate_now (se.string_length, &se.pre);
1621 gfc_add_block_to_block (block, &se.pre);
1622 gfc_add_block_to_block (block, &se.post);
1624 e->ts.u.cl->backend_decl = *len;
1629 /* Figure out the string length of a variable reference expression.
1630 Used by get_array_ctor_strlen. */
1633 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1639 /* Don't bother if we already know the length is a constant. */
1640 if (*len && INTEGER_CST_P (*len))
1643 ts = &expr->symtree->n.sym->ts;
1644 for (ref = expr->ref; ref; ref = ref->next)
1649 /* Array references don't change the string length. */
1653 /* Use the length of the component. */
1654 ts = &ref->u.c.component->ts;
1658 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1659 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1661 /* Note that this might evaluate expr. */
1662 get_array_ctor_all_strlen (block, expr, len);
1665 mpz_init_set_ui (char_len, 1);
1666 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1667 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1668 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1669 *len = convert (gfc_charlen_type_node, *len);
1670 mpz_clear (char_len);
1678 *len = ts->u.cl->backend_decl;
1682 /* Figure out the string length of a character array constructor.
1683 If len is NULL, don't calculate the length; this happens for recursive calls
1684 when a sub-array-constructor is an element but not at the first position,
1685 so when we're not interested in the length.
1686 Returns TRUE if all elements are character constants. */
1689 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1696 if (gfc_constructor_first (base) == NULL)
1699 *len = build_int_cstu (gfc_charlen_type_node, 0);
1703 /* Loop over all constructor elements to find out is_const, but in len we
1704 want to store the length of the first, not the last, element. We can
1705 of course exit the loop as soon as is_const is found to be false. */
1706 for (c = gfc_constructor_first (base);
1707 c && is_const; c = gfc_constructor_next (c))
1709 switch (c->expr->expr_type)
1712 if (len && !(*len && INTEGER_CST_P (*len)))
1713 *len = build_int_cstu (gfc_charlen_type_node,
1714 c->expr->value.character.length);
1718 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1725 get_array_ctor_var_strlen (block, c->expr, len);
1731 get_array_ctor_all_strlen (block, c->expr, len);
1735 /* After the first iteration, we don't want the length modified. */
1742 /* Check whether the array constructor C consists entirely of constant
1743 elements, and if so returns the number of those elements, otherwise
1744 return zero. Note, an empty or NULL array constructor returns zero. */
1746 unsigned HOST_WIDE_INT
1747 gfc_constant_array_constructor_p (gfc_constructor_base base)
1749 unsigned HOST_WIDE_INT nelem = 0;
1751 gfc_constructor *c = gfc_constructor_first (base);
1755 || c->expr->rank > 0
1756 || c->expr->expr_type != EXPR_CONSTANT)
1758 c = gfc_constructor_next (c);
1765 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1766 and the tree type of it's elements, TYPE, return a static constant
1767 variable that is compile-time initialized. */
1770 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1772 tree tmptype, init, tmp;
1773 HOST_WIDE_INT nelem;
1778 VEC(constructor_elt,gc) *v = NULL;
1780 /* First traverse the constructor list, converting the constants
1781 to tree to build an initializer. */
1783 c = gfc_constructor_first (expr->value.constructor);
1786 gfc_init_se (&se, NULL);
1787 gfc_conv_constant (&se, c->expr);
1788 if (c->expr->ts.type != BT_CHARACTER)
1789 se.expr = fold_convert (type, se.expr);
1790 else if (POINTER_TYPE_P (type))
1791 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1793 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1795 c = gfc_constructor_next (c);
1799 /* Next determine the tree type for the array. We use the gfortran
1800 front-end's gfc_get_nodesc_array_type in order to create a suitable
1801 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1803 memset (&as, 0, sizeof (gfc_array_spec));
1805 as.rank = expr->rank;
1806 as.type = AS_EXPLICIT;
1809 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1810 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1814 for (i = 0; i < expr->rank; i++)
1816 int tmp = (int) mpz_get_si (expr->shape[i]);
1817 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1818 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1822 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1824 /* as is not needed anymore. */
1825 for (i = 0; i < as.rank + as.corank; i++)
1827 gfc_free_expr (as.lower[i]);
1828 gfc_free_expr (as.upper[i]);
1831 init = build_constructor (tmptype, v);
1833 TREE_CONSTANT (init) = 1;
1834 TREE_STATIC (init) = 1;
1836 tmp = gfc_create_var (tmptype, "A");
1837 TREE_STATIC (tmp) = 1;
1838 TREE_CONSTANT (tmp) = 1;
1839 TREE_READONLY (tmp) = 1;
1840 DECL_INITIAL (tmp) = init;
1846 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1847 This mostly initializes the scalarizer state info structure with the
1848 appropriate values to directly use the array created by the function
1849 gfc_build_constant_array_constructor. */
1852 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1853 gfc_ss * ss, tree type)
1859 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1861 info = &ss->data.info;
1863 info->descriptor = tmp;
1864 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1865 info->offset = gfc_index_zero_node;
1867 for (i = 0; i < info->dimen; i++)
1869 info->delta[i] = gfc_index_zero_node;
1870 info->start[i] = gfc_index_zero_node;
1871 info->end[i] = gfc_index_zero_node;
1872 info->stride[i] = gfc_index_one_node;
1875 if (info->dimen > loop->temp_dim)
1876 loop->temp_dim = info->dimen;
1879 /* Helper routine of gfc_trans_array_constructor to determine if the
1880 bounds of the loop specified by LOOP are constant and simple enough
1881 to use with gfc_trans_constant_array_constructor. Returns the
1882 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1885 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1887 tree size = gfc_index_one_node;
1891 for (i = 0; i < loop->dimen; i++)
1893 /* If the bounds aren't constant, return NULL_TREE. */
1894 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1896 if (!integer_zerop (loop->from[i]))
1898 /* Only allow nonzero "from" in one-dimensional arrays. */
1899 if (loop->dimen != 1)
1901 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1902 gfc_array_index_type,
1903 loop->to[i], loop->from[i]);
1907 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1908 tmp, gfc_index_one_node);
1909 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1917 /* Array constructors are handled by constructing a temporary, then using that
1918 within the scalarization loop. This is not optimal, but seems by far the
1922 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1924 gfc_constructor_base c;
1931 bool old_first_len, old_typespec_chararray_ctor;
1932 tree old_first_len_val;
1934 /* Save the old values for nested checking. */
1935 old_first_len = first_len;
1936 old_first_len_val = first_len_val;
1937 old_typespec_chararray_ctor = typespec_chararray_ctor;
1939 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1940 typespec was given for the array constructor. */
1941 typespec_chararray_ctor = (ss->expr->ts.u.cl
1942 && ss->expr->ts.u.cl->length_from_typespec);
1944 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1945 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1947 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1951 gcc_assert (ss->data.info.dimen == loop->dimen);
1953 c = ss->expr->value.constructor;
1954 if (ss->expr->ts.type == BT_CHARACTER)
1958 /* get_array_ctor_strlen walks the elements of the constructor, if a
1959 typespec was given, we already know the string length and want the one
1961 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1962 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1966 const_string = false;
1967 gfc_init_se (&length_se, NULL);
1968 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1969 gfc_charlen_type_node);
1970 ss->string_length = length_se.expr;
1971 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1972 gfc_add_block_to_block (&loop->post, &length_se.post);
1975 const_string = get_array_ctor_strlen (&loop->pre, c,
1976 &ss->string_length);
1978 /* Complex character array constructors should have been taken care of
1979 and not end up here. */
1980 gcc_assert (ss->string_length);
1982 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1984 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1986 type = build_pointer_type (type);
1989 type = gfc_typenode_for_spec (&ss->expr->ts);
1991 /* See if the constructor determines the loop bounds. */
1994 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1996 /* We have a multidimensional parameter. */
1998 for (n = 0; n < ss->expr->rank; n++)
2000 loop->from[n] = gfc_index_zero_node;
2001 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
2002 gfc_index_integer_kind);
2003 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2004 gfc_array_index_type,
2005 loop->to[n], gfc_index_one_node);
2009 if (loop->to[0] == NULL_TREE)
2013 /* We should have a 1-dimensional, zero-based loop. */
2014 gcc_assert (loop->dimen == 1);
2015 gcc_assert (integer_zerop (loop->from[0]));
2017 /* Split the constructor size into a static part and a dynamic part.
2018 Allocate the static size up-front and record whether the dynamic
2019 size might be nonzero. */
2021 dynamic = gfc_get_array_constructor_size (&size, c);
2022 mpz_sub_ui (size, size, 1);
2023 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2027 /* Special case constant array constructors. */
2030 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2033 tree size = constant_array_constructor_loop_size (loop);
2034 if (size && compare_tree_int (size, nelem) == 0)
2036 gfc_trans_constant_array_constructor (loop, ss, type);
2042 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2045 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
2046 type, NULL_TREE, dynamic, true, false, where);
2048 desc = ss->data.info.descriptor;
2049 offset = gfc_index_zero_node;
2050 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2051 TREE_NO_WARNING (offsetvar) = 1;
2052 TREE_USED (offsetvar) = 0;
2053 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2054 &offset, &offsetvar, dynamic);
2056 /* If the array grows dynamically, the upper bound of the loop variable
2057 is determined by the array's final upper bound. */
2060 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2061 gfc_array_index_type,
2062 offsetvar, gfc_index_one_node);
2063 tmp = gfc_evaluate_now (tmp, &loop->pre);
2064 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2065 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2066 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2071 if (TREE_USED (offsetvar))
2072 pushdecl (offsetvar);
2074 gcc_assert (INTEGER_CST_P (offset));
2077 /* Disable bound checking for now because it's probably broken. */
2078 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2085 /* Restore old values of globals. */
2086 first_len = old_first_len;
2087 first_len_val = old_first_len_val;
2088 typespec_chararray_ctor = old_typespec_chararray_ctor;
2092 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2093 called after evaluating all of INFO's vector dimensions. Go through
2094 each such vector dimension and see if we can now fill in any missing
2098 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2107 for (n = 0; n < loop->dimen; n++)
2110 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2111 && loop->to[n] == NULL)
2113 /* Loop variable N indexes vector dimension DIM, and we don't
2114 yet know the upper bound of loop variable N. Set it to the
2115 difference between the vector's upper and lower bounds. */
2116 gcc_assert (loop->from[n] == gfc_index_zero_node);
2117 gcc_assert (info->subscript[dim]
2118 && info->subscript[dim]->type == GFC_SS_VECTOR);
2120 gfc_init_se (&se, NULL);
2121 desc = info->subscript[dim]->data.info.descriptor;
2122 zero = gfc_rank_cst[0];
2123 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2124 gfc_array_index_type,
2125 gfc_conv_descriptor_ubound_get (desc, zero),
2126 gfc_conv_descriptor_lbound_get (desc, zero));
2127 tmp = gfc_evaluate_now (tmp, &loop->pre);
2134 /* Add the pre and post chains for all the scalar expressions in a SS chain
2135 to loop. This is called after the loop parameters have been calculated,
2136 but before the actual scalarizing loops. */
2139 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2145 /* TODO: This can generate bad code if there are ordering dependencies,
2146 e.g., a callee allocated function and an unknown size constructor. */
2147 gcc_assert (ss != NULL);
2149 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2156 /* Scalar expression. Evaluate this now. This includes elemental
2157 dimension indices, but not array section bounds. */
2158 gfc_init_se (&se, NULL);
2159 gfc_conv_expr (&se, ss->expr);
2160 gfc_add_block_to_block (&loop->pre, &se.pre);
2162 if (ss->expr->ts.type != BT_CHARACTER)
2164 /* Move the evaluation of scalar expressions outside the
2165 scalarization loop, except for WHERE assignments. */
2167 se.expr = convert(gfc_array_index_type, se.expr);
2169 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2170 gfc_add_block_to_block (&loop->pre, &se.post);
2173 gfc_add_block_to_block (&loop->post, &se.post);
2175 ss->data.scalar.expr = se.expr;
2176 ss->string_length = se.string_length;
2179 case GFC_SS_REFERENCE:
2180 /* Scalar argument to elemental procedure. Evaluate this
2182 gfc_init_se (&se, NULL);
2183 gfc_conv_expr (&se, ss->expr);
2184 gfc_add_block_to_block (&loop->pre, &se.pre);
2185 gfc_add_block_to_block (&loop->post, &se.post);
2187 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2188 ss->string_length = se.string_length;
2191 case GFC_SS_SECTION:
2192 /* Add the expressions for scalar and vector subscripts. */
2193 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2194 if (ss->data.info.subscript[n])
2195 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2198 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2202 /* Get the vector's descriptor and store it in SS. */
2203 gfc_init_se (&se, NULL);
2204 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2205 gfc_add_block_to_block (&loop->pre, &se.pre);
2206 gfc_add_block_to_block (&loop->post, &se.post);
2207 ss->data.info.descriptor = se.expr;
2210 case GFC_SS_INTRINSIC:
2211 gfc_add_intrinsic_ss_code (loop, ss);
2214 case GFC_SS_FUNCTION:
2215 /* Array function return value. We call the function and save its
2216 result in a temporary for use inside the loop. */
2217 gfc_init_se (&se, NULL);
2220 gfc_conv_expr (&se, ss->expr);
2221 gfc_add_block_to_block (&loop->pre, &se.pre);
2222 gfc_add_block_to_block (&loop->post, &se.post);
2223 ss->string_length = se.string_length;
2226 case GFC_SS_CONSTRUCTOR:
2227 if (ss->expr->ts.type == BT_CHARACTER
2228 && ss->string_length == NULL
2229 && ss->expr->ts.u.cl
2230 && ss->expr->ts.u.cl->length)
2232 gfc_init_se (&se, NULL);
2233 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2234 gfc_charlen_type_node);
2235 ss->string_length = se.expr;
2236 gfc_add_block_to_block (&loop->pre, &se.pre);
2237 gfc_add_block_to_block (&loop->post, &se.post);
2239 gfc_trans_array_constructor (loop, ss, where);
2243 case GFC_SS_COMPONENT:
2244 /* Do nothing. These are handled elsewhere. */
2254 /* Translate expressions for the descriptor and data pointer of a SS. */
2258 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2263 /* Get the descriptor for the array to be scalarized. */
2264 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2265 gfc_init_se (&se, NULL);
2266 se.descriptor_only = 1;
2267 gfc_conv_expr_lhs (&se, ss->expr);
2268 gfc_add_block_to_block (block, &se.pre);
2269 ss->data.info.descriptor = se.expr;
2270 ss->string_length = se.string_length;
2274 /* Also the data pointer. */
2275 tmp = gfc_conv_array_data (se.expr);
2276 /* If this is a variable or address of a variable we use it directly.
2277 Otherwise we must evaluate it now to avoid breaking dependency
2278 analysis by pulling the expressions for elemental array indices
2281 || (TREE_CODE (tmp) == ADDR_EXPR
2282 && DECL_P (TREE_OPERAND (tmp, 0)))))
2283 tmp = gfc_evaluate_now (tmp, block);
2284 ss->data.info.data = tmp;
2286 tmp = gfc_conv_array_offset (se.expr);
2287 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2289 /* Make absolutely sure that the saved_offset is indeed saved
2290 so that the variable is still accessible after the loops
2292 ss->data.info.saved_offset = ss->data.info.offset;
2297 /* Initialize a gfc_loopinfo structure. */
2300 gfc_init_loopinfo (gfc_loopinfo * loop)
2304 memset (loop, 0, sizeof (gfc_loopinfo));
2305 gfc_init_block (&loop->pre);
2306 gfc_init_block (&loop->post);
2308 /* Initially scalarize in order and default to no loop reversal. */
2309 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2312 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2315 loop->ss = gfc_ss_terminator;
2319 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2323 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2329 /* Return an expression for the data pointer of an array. */
2332 gfc_conv_array_data (tree descriptor)
2336 type = TREE_TYPE (descriptor);
2337 if (GFC_ARRAY_TYPE_P (type))
2339 if (TREE_CODE (type) == POINTER_TYPE)
2343 /* Descriptorless arrays. */
2344 return gfc_build_addr_expr (NULL_TREE, descriptor);
2348 return gfc_conv_descriptor_data_get (descriptor);
2352 /* Return an expression for the base offset of an array. */
2355 gfc_conv_array_offset (tree descriptor)
2359 type = TREE_TYPE (descriptor);
2360 if (GFC_ARRAY_TYPE_P (type))
2361 return GFC_TYPE_ARRAY_OFFSET (type);
2363 return gfc_conv_descriptor_offset_get (descriptor);
2367 /* Get an expression for the array stride. */
2370 gfc_conv_array_stride (tree descriptor, int dim)
2375 type = TREE_TYPE (descriptor);
2377 /* For descriptorless arrays use the array size. */
2378 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2379 if (tmp != NULL_TREE)
2382 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2387 /* Like gfc_conv_array_stride, but for the lower bound. */
2390 gfc_conv_array_lbound (tree descriptor, int dim)
2395 type = TREE_TYPE (descriptor);
2397 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2398 if (tmp != NULL_TREE)
2401 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2406 /* Like gfc_conv_array_stride, but for the upper bound. */
2409 gfc_conv_array_ubound (tree descriptor, int dim)
2414 type = TREE_TYPE (descriptor);
2416 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2417 if (tmp != NULL_TREE)
2420 /* This should only ever happen when passing an assumed shape array
2421 as an actual parameter. The value will never be used. */
2422 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2423 return gfc_index_zero_node;
2425 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2430 /* Generate code to perform an array index bound check. */
2433 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2434 locus * where, bool check_upper)
2437 tree tmp_lo, tmp_up;
2439 const char * name = NULL;
2441 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2444 index = gfc_evaluate_now (index, &se->pre);
2446 /* We find a name for the error message. */
2448 name = se->ss->expr->symtree->name;
2450 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2451 && se->loop->ss->expr->symtree)
2452 name = se->loop->ss->expr->symtree->name;
2454 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2455 && se->loop->ss->loop_chain->expr
2456 && se->loop->ss->loop_chain->expr->symtree)
2457 name = se->loop->ss->loop_chain->expr->symtree->name;
2459 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2461 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2462 && se->loop->ss->expr->value.function.name)
2463 name = se->loop->ss->expr->value.function.name;
2465 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2466 || se->loop->ss->type == GFC_SS_SCALAR)
2467 name = "unnamed constant";
2470 if (TREE_CODE (descriptor) == VAR_DECL)
2471 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2473 /* If upper bound is present, include both bounds in the error message. */
2476 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2477 tmp_up = gfc_conv_array_ubound (descriptor, n);
2480 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2481 "outside of expected range (%%ld:%%ld)", n+1, name);
2483 asprintf (&msg, "Index '%%ld' of dimension %d "
2484 "outside of expected range (%%ld:%%ld)", n+1);
2486 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2488 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2489 fold_convert (long_integer_type_node, index),
2490 fold_convert (long_integer_type_node, tmp_lo),
2491 fold_convert (long_integer_type_node, tmp_up));
2492 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2494 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2495 fold_convert (long_integer_type_node, index),
2496 fold_convert (long_integer_type_node, tmp_lo),
2497 fold_convert (long_integer_type_node, tmp_up));
2502 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2505 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2506 "below lower bound of %%ld", n+1, name);
2508 asprintf (&msg, "Index '%%ld' of dimension %d "
2509 "below lower bound of %%ld", n+1);
2511 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2513 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2514 fold_convert (long_integer_type_node, index),
2515 fold_convert (long_integer_type_node, tmp_lo));
2523 /* Return the offset for an index. Performs bound checking for elemental
2524 dimensions. Single element references are processed separately.
2525 DIM is the array dimension, I is the loop dimension. */
2528 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2529 gfc_array_ref * ar, tree stride)
2535 /* Get the index into the array for this dimension. */
2538 gcc_assert (ar->type != AR_ELEMENT);
2539 switch (ar->dimen_type[dim])
2541 case DIMEN_THIS_IMAGE:
2545 /* Elemental dimension. */
2546 gcc_assert (info->subscript[dim]
2547 && info->subscript[dim]->type == GFC_SS_SCALAR);
2548 /* We've already translated this value outside the loop. */
2549 index = info->subscript[dim]->data.scalar.expr;
2551 index = gfc_trans_array_bound_check (se, info->descriptor,
2552 index, dim, &ar->where,
2553 ar->as->type != AS_ASSUMED_SIZE
2554 || dim < ar->dimen - 1);
2558 gcc_assert (info && se->loop);
2559 gcc_assert (info->subscript[dim]
2560 && info->subscript[dim]->type == GFC_SS_VECTOR);
2561 desc = info->subscript[dim]->data.info.descriptor;
2563 /* Get a zero-based index into the vector. */
2564 index = fold_build2_loc (input_location, MINUS_EXPR,
2565 gfc_array_index_type,
2566 se->loop->loopvar[i], se->loop->from[i]);
2568 /* Multiply the index by the stride. */
2569 index = fold_build2_loc (input_location, MULT_EXPR,
2570 gfc_array_index_type,
2571 index, gfc_conv_array_stride (desc, 0));
2573 /* Read the vector to get an index into info->descriptor. */
2574 data = build_fold_indirect_ref_loc (input_location,
2575 gfc_conv_array_data (desc));
2576 index = gfc_build_array_ref (data, index, NULL);
2577 index = gfc_evaluate_now (index, &se->pre);
2578 index = fold_convert (gfc_array_index_type, index);
2580 /* Do any bounds checking on the final info->descriptor index. */
2581 index = gfc_trans_array_bound_check (se, info->descriptor,
2582 index, dim, &ar->where,
2583 ar->as->type != AS_ASSUMED_SIZE
2584 || dim < ar->dimen - 1);
2588 /* Scalarized dimension. */
2589 gcc_assert (info && se->loop);
2591 /* Multiply the loop variable by the stride and delta. */
2592 index = se->loop->loopvar[i];
2593 if (!integer_onep (info->stride[dim]))
2594 index = fold_build2_loc (input_location, MULT_EXPR,
2595 gfc_array_index_type, index,
2597 if (!integer_zerop (info->delta[dim]))
2598 index = fold_build2_loc (input_location, PLUS_EXPR,
2599 gfc_array_index_type, index,
2609 /* Temporary array or derived type component. */
2610 gcc_assert (se->loop);
2611 index = se->loop->loopvar[se->loop->order[i]];
2613 /* Pointer functions can have stride[0] different from unity.
2614 Use the stride returned by the function call and stored in
2615 the descriptor for the temporary. */
2616 if (se->ss && se->ss->type == GFC_SS_FUNCTION
2618 && se->ss->expr->symtree
2619 && se->ss->expr->symtree->n.sym->result
2620 && se->ss->expr->symtree->n.sym->result->attr.pointer)
2621 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2624 if (!integer_zerop (info->delta[dim]))
2625 index = fold_build2_loc (input_location, PLUS_EXPR,
2626 gfc_array_index_type, index, info->delta[dim]);
2629 /* Multiply by the stride. */
2630 if (!integer_onep (stride))
2631 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2638 /* Build a scalarized reference to an array. */
2641 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2644 tree decl = NULL_TREE;
2649 info = &se->ss->data.info;
2651 n = se->loop->order[0];
2655 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2657 /* Add the offset for this dimension to the stored offset for all other
2659 if (!integer_zerop (info->offset))
2660 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2661 index, info->offset);
2663 if (se->ss->expr && is_subref_array (se->ss->expr))
2664 decl = se->ss->expr->symtree->n.sym->backend_decl;
2666 tmp = build_fold_indirect_ref_loc (input_location,
2668 se->expr = gfc_build_array_ref (tmp, index, decl);
2672 /* Translate access of temporary array. */
2675 gfc_conv_tmp_array_ref (gfc_se * se)
2677 se->string_length = se->ss->string_length;
2678 gfc_conv_scalarized_array_ref (se, NULL);
2679 gfc_advance_se_ss_chain (se);
2682 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2685 add_to_offset (tree *cst_offset, tree *offset, tree t)
2687 if (TREE_CODE (t) == INTEGER_CST)
2688 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2691 if (!integer_zerop (*offset))
2692 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2693 gfc_array_index_type, *offset, t);
2699 /* Build an array reference. se->expr already holds the array descriptor.
2700 This should be either a variable, indirect variable reference or component
2701 reference. For arrays which do not have a descriptor, se->expr will be
2703 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2706 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2710 tree offset, cst_offset;
2718 gcc_assert (ar->codimen);
2720 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2721 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2724 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2725 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2726 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2728 /* Use the actual tree type and not the wrapped coarray. */
2729 if (!se->want_pointer)
2730 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2737 /* Handle scalarized references separately. */
2738 if (ar->type != AR_ELEMENT)
2740 gfc_conv_scalarized_array_ref (se, ar);
2741 gfc_advance_se_ss_chain (se);
2745 cst_offset = offset = gfc_index_zero_node;
2746 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2748 /* Calculate the offsets from all the dimensions. Make sure to associate
2749 the final offset so that we form a chain of loop invariant summands. */
2750 for (n = ar->dimen - 1; n >= 0; n--)
2752 /* Calculate the index for this dimension. */
2753 gfc_init_se (&indexse, se);
2754 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2755 gfc_add_block_to_block (&se->pre, &indexse.pre);
2757 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2759 /* Check array bounds. */
2763 /* Evaluate the indexse.expr only once. */
2764 indexse.expr = save_expr (indexse.expr);
2767 tmp = gfc_conv_array_lbound (se->expr, n);
2768 if (sym->attr.temporary)
2770 gfc_init_se (&tmpse, se);
2771 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2772 gfc_array_index_type);
2773 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2777 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2779 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2780 "below lower bound of %%ld", n+1, sym->name);
2781 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2782 fold_convert (long_integer_type_node,
2784 fold_convert (long_integer_type_node, tmp));
2787 /* Upper bound, but not for the last dimension of assumed-size
2789 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2791 tmp = gfc_conv_array_ubound (se->expr, n);
2792 if (sym->attr.temporary)
2794 gfc_init_se (&tmpse, se);
2795 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2796 gfc_array_index_type);
2797 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2801 cond = fold_build2_loc (input_location, GT_EXPR,
2802 boolean_type_node, indexse.expr, tmp);
2803 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2804 "above upper bound of %%ld", n+1, sym->name);
2805 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2806 fold_convert (long_integer_type_node,
2808 fold_convert (long_integer_type_node, tmp));
2813 /* Multiply the index by the stride. */
2814 stride = gfc_conv_array_stride (se->expr, n);
2815 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2816 indexse.expr, stride);
2818 /* And add it to the total. */
2819 add_to_offset (&cst_offset, &offset, tmp);
2822 if (!integer_zerop (cst_offset))
2823 offset = fold_build2_loc (input_location, PLUS_EXPR,
2824 gfc_array_index_type, offset, cst_offset);
2826 /* Access the calculated element. */
2827 tmp = gfc_conv_array_data (se->expr);
2828 tmp = build_fold_indirect_ref (tmp);
2829 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2833 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
2834 LOOP_DIM dimension (if any) to array's offset. */
2837 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
2838 gfc_array_ref *ar, int array_dim, int loop_dim)
2844 info = &ss->data.info;
2846 gfc_init_se (&se, NULL);
2848 se.expr = info->descriptor;
2849 stride = gfc_conv_array_stride (info->descriptor, array_dim);
2850 index = gfc_conv_array_index_offset (&se, info, array_dim, loop_dim, ar,
2852 gfc_add_block_to_block (pblock, &se.pre);
2854 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2855 gfc_array_index_type,
2856 info->offset, index);
2857 info->offset = gfc_evaluate_now (info->offset, pblock);
2861 /* Generate the code to be executed immediately before entering a
2862 scalarization loop. */
2865 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2866 stmtblock_t * pblock)
2874 /* This code will be executed before entering the scalarization loop
2875 for this dimension. */
2876 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2878 if ((ss->useflags & flag) == 0)
2881 if (ss->type != GFC_SS_SECTION
2882 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2883 && ss->type != GFC_SS_COMPONENT)
2886 info = &ss->data.info;
2888 gcc_assert (dim < info->dimen);
2889 gcc_assert (info->dimen == loop->dimen);
2892 ar = &info->ref->u.ar;
2896 if (dim == loop->dimen - 1)
2901 /* For the time being, there is no loop reordering. */
2902 gcc_assert (i == loop->order[i]);
2905 if (dim == loop->dimen - 1)
2907 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2909 /* Calculate the stride of the innermost loop. Hopefully this will
2910 allow the backend optimizers to do their stuff more effectively.
2912 info->stride0 = gfc_evaluate_now (stride, pblock);
2914 /* For the outermost loop calculate the offset due to any
2915 elemental dimensions. It will have been initialized with the
2916 base offset of the array. */
2919 for (i = 0; i < ar->dimen; i++)
2921 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2924 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
2929 /* Add the offset for the previous loop dimension. */
2930 add_array_offset (pblock, loop, ss, ar, info->dim[i], i);
2932 /* Remember this offset for the second loop. */
2933 if (dim == loop->temp_dim - 1)
2934 info->saved_offset = info->offset;
2939 /* Start a scalarized expression. Creates a scope and declares loop
2943 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2949 gcc_assert (!loop->array_parameter);
2951 for (dim = loop->dimen - 1; dim >= 0; dim--)
2953 n = loop->order[dim];
2955 gfc_start_block (&loop->code[n]);
2957 /* Create the loop variable. */
2958 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2960 if (dim < loop->temp_dim)
2964 /* Calculate values that will be constant within this loop. */
2965 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2967 gfc_start_block (pbody);
2971 /* Generates the actual loop code for a scalarization loop. */
2974 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2975 stmtblock_t * pbody)
2986 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2987 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2988 && n == loop->dimen - 1)
2990 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2991 init = make_tree_vec (1);
2992 cond = make_tree_vec (1);
2993 incr = make_tree_vec (1);
2995 /* Cycle statement is implemented with a goto. Exit statement must not
2996 be present for this loop. */
2997 exit_label = gfc_build_label_decl (NULL_TREE);
2998 TREE_USED (exit_label) = 1;
3000 /* Label for cycle statements (if needed). */
3001 tmp = build1_v (LABEL_EXPR, exit_label);
3002 gfc_add_expr_to_block (pbody, tmp);
3004 stmt = make_node (OMP_FOR);
3006 TREE_TYPE (stmt) = void_type_node;
3007 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3009 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3010 OMP_CLAUSE_SCHEDULE);
3011 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3012 = OMP_CLAUSE_SCHEDULE_STATIC;
3013 if (ompws_flags & OMPWS_NOWAIT)
3014 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3015 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3017 /* Initialize the loopvar. */
3018 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3020 OMP_FOR_INIT (stmt) = init;
3021 /* The exit condition. */
3022 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3024 loop->loopvar[n], loop->to[n]);
3025 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3026 OMP_FOR_COND (stmt) = cond;
3027 /* Increment the loopvar. */
3028 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3029 loop->loopvar[n], gfc_index_one_node);
3030 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3031 void_type_node, loop->loopvar[n], tmp);
3032 OMP_FOR_INCR (stmt) = incr;
3034 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3035 gfc_add_expr_to_block (&loop->code[n], stmt);
3039 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3040 && (loop->temp_ss == NULL);
3042 loopbody = gfc_finish_block (pbody);
3046 tmp = loop->from[n];
3047 loop->from[n] = loop->to[n];
3051 /* Initialize the loopvar. */
3052 if (loop->loopvar[n] != loop->from[n])
3053 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3055 exit_label = gfc_build_label_decl (NULL_TREE);
3057 /* Generate the loop body. */
3058 gfc_init_block (&block);
3060 /* The exit condition. */
3061 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3062 boolean_type_node, loop->loopvar[n], loop->to[n]);
3063 tmp = build1_v (GOTO_EXPR, exit_label);
3064 TREE_USED (exit_label) = 1;
3065 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3066 gfc_add_expr_to_block (&block, tmp);
3068 /* The main body. */
3069 gfc_add_expr_to_block (&block, loopbody);
3071 /* Increment the loopvar. */
3072 tmp = fold_build2_loc (input_location,
3073 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3074 gfc_array_index_type, loop->loopvar[n],
3075 gfc_index_one_node);
3077 gfc_add_modify (&block, loop->loopvar[n], tmp);
3079 /* Build the loop. */
3080 tmp = gfc_finish_block (&block);
3081 tmp = build1_v (LOOP_EXPR, tmp);
3082 gfc_add_expr_to_block (&loop->code[n], tmp);
3084 /* Add the exit label. */
3085 tmp = build1_v (LABEL_EXPR, exit_label);
3086 gfc_add_expr_to_block (&loop->code[n], tmp);
3092 /* Finishes and generates the loops for a scalarized expression. */
3095 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3100 stmtblock_t *pblock;
3104 /* Generate the loops. */
3105 for (dim = 0; dim < loop->dimen; dim++)
3107 n = loop->order[dim];
3108 gfc_trans_scalarized_loop_end (loop, n, pblock);
3109 loop->loopvar[n] = NULL_TREE;
3110 pblock = &loop->code[n];
3113 tmp = gfc_finish_block (pblock);
3114 gfc_add_expr_to_block (&loop->pre, tmp);
3116 /* Clear all the used flags. */
3117 for (ss = loop->ss; ss; ss = ss->loop_chain)
3122 /* Finish the main body of a scalarized expression, and start the secondary
3126 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3130 stmtblock_t *pblock;
3134 /* We finish as many loops as are used by the temporary. */
3135 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3137 n = loop->order[dim];
3138 gfc_trans_scalarized_loop_end (loop, n, pblock);
3139 loop->loopvar[n] = NULL_TREE;
3140 pblock = &loop->code[n];
3143 /* We don't want to finish the outermost loop entirely. */
3144 n = loop->order[loop->temp_dim - 1];
3145 gfc_trans_scalarized_loop_end (loop, n, pblock);
3147 /* Restore the initial offsets. */
3148 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3150 if ((ss->useflags & 2) == 0)
3153 if (ss->type != GFC_SS_SECTION
3154 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3155 && ss->type != GFC_SS_COMPONENT)
3158 ss->data.info.offset = ss->data.info.saved_offset;
3161 /* Restart all the inner loops we just finished. */
3162 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3164 n = loop->order[dim];
3166 gfc_start_block (&loop->code[n]);
3168 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3170 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3173 /* Start a block for the secondary copying code. */
3174 gfc_start_block (body);
3178 /* Precalculate (either lower or upper) bound of an array section.
3179 BLOCK: Block in which the (pre)calculation code will go.
3180 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3181 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3182 DESC: Array descriptor from which the bound will be picked if unspecified
3183 (either lower or upper bound according to LBOUND). */
3186 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3187 tree desc, int dim, bool lbound)
3190 gfc_expr * input_val = values[dim];
3191 tree *output = &bounds[dim];
3196 /* Specified section bound. */
3197 gfc_init_se (&se, NULL);
3198 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3199 gfc_add_block_to_block (block, &se.pre);
3204 /* No specific bound specified so use the bound of the array. */
3205 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3206 gfc_conv_array_ubound (desc, dim);
3208 *output = gfc_evaluate_now (*output, block);
3212 /* Calculate the lower bound of an array section. */
3215 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3217 gfc_expr *stride = NULL;
3223 gcc_assert (ss->type == GFC_SS_SECTION);
3225 info = &ss->data.info;
3226 ar = &info->ref->u.ar;
3228 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3230 /* We use a zero-based index to access the vector. */
3231 info->start[dim] = gfc_index_zero_node;
3232 info->end[dim] = NULL;
3233 info->stride[dim] = gfc_index_one_node;
3237 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3238 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3239 desc = info->descriptor;
3240 stride = ar->stride[dim];
3242 /* Calculate the start of the range. For vector subscripts this will
3243 be the range of the vector. */
3244 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3246 /* Similarly calculate the end. Although this is not used in the
3247 scalarizer, it is needed when checking bounds and where the end
3248 is an expression with side-effects. */
3249 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3251 /* Calculate the stride. */
3253 info->stride[dim] = gfc_index_one_node;
3256 gfc_init_se (&se, NULL);
3257 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3258 gfc_add_block_to_block (&loop->pre, &se.pre);
3259 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3264 /* Calculates the range start and stride for a SS chain. Also gets the
3265 descriptor and data pointer. The range of vector subscripts is the size
3266 of the vector. Array bounds are also checked. */
3269 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3277 /* Determine the rank of the loop. */
3278 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3282 case GFC_SS_SECTION:
3283 case GFC_SS_CONSTRUCTOR:
3284 case GFC_SS_FUNCTION:
3285 case GFC_SS_COMPONENT:
3286 loop->dimen = ss->data.info.dimen;
3289 /* As usual, lbound and ubound are exceptions!. */
3290 case GFC_SS_INTRINSIC:
3291 switch (ss->expr->value.function.isym->id)
3293 case GFC_ISYM_LBOUND:
3294 case GFC_ISYM_UBOUND:
3295 case GFC_ISYM_LCOBOUND:
3296 case GFC_ISYM_UCOBOUND:
3297 case GFC_ISYM_THIS_IMAGE:
3298 loop->dimen = ss->data.info.dimen;
3310 /* We should have determined the rank of the expression by now. If
3311 not, that's bad news. */
3315 /* Loop over all the SS in the chain. */
3316 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3318 if (ss->expr && ss->expr->shape && !ss->shape)
3319 ss->shape = ss->expr->shape;
3323 case GFC_SS_SECTION:
3324 /* Get the descriptor for the array. */
3325 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3327 for (n = 0; n < ss->data.info.dimen; n++)
3328 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3331 case GFC_SS_INTRINSIC:
3332 switch (ss->expr->value.function.isym->id)
3334 /* Fall through to supply start and stride. */
3335 case GFC_ISYM_LBOUND:
3336 case GFC_ISYM_UBOUND:
3337 case GFC_ISYM_LCOBOUND:
3338 case GFC_ISYM_UCOBOUND:
3339 case GFC_ISYM_THIS_IMAGE:
3346 case GFC_SS_CONSTRUCTOR:
3347 case GFC_SS_FUNCTION:
3348 for (n = 0; n < ss->data.info.dimen; n++)
3350 int dim = ss->data.info.dim[n];
3352 ss->data.info.start[dim] = gfc_index_zero_node;
3353 ss->data.info.end[dim] = gfc_index_zero_node;
3354 ss->data.info.stride[dim] = gfc_index_one_node;
3363 /* The rest is just runtime bound checking. */
3364 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3367 tree lbound, ubound;
3369 tree size[GFC_MAX_DIMENSIONS];
3370 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3375 gfc_start_block (&block);
3377 for (n = 0; n < loop->dimen; n++)
3378 size[n] = NULL_TREE;
3380 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3384 if (ss->type != GFC_SS_SECTION)
3387 /* Catch allocatable lhs in f2003. */
3388 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3391 gfc_start_block (&inner);
3393 /* TODO: range checking for mapped dimensions. */
3394 info = &ss->data.info;
3396 /* This code only checks ranges. Elemental and vector
3397 dimensions are checked later. */
3398 for (n = 0; n < loop->dimen; n++)
3403 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3406 if (dim == info->ref->u.ar.dimen - 1
3407 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3408 check_upper = false;
3412 /* Zero stride is not allowed. */
3413 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3414 info->stride[dim], gfc_index_zero_node);
3415 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3416 "of array '%s'", dim + 1, ss->expr->symtree->name);
3417 gfc_trans_runtime_check (true, false, tmp, &inner,
3418 &ss->expr->where, msg);
3421 desc = ss->data.info.descriptor;
3423 /* This is the run-time equivalent of resolve.c's
3424 check_dimension(). The logical is more readable there
3425 than it is here, with all the trees. */
3426 lbound = gfc_conv_array_lbound (desc, dim);
3427 end = info->end[dim];
3429 ubound = gfc_conv_array_ubound (desc, dim);
3433 /* non_zerosized is true when the selected range is not
3435 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3436 boolean_type_node, info->stride[dim],
3437 gfc_index_zero_node);
3438 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3439 info->start[dim], end);
3440 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3441 boolean_type_node, stride_pos, tmp);
3443 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3445 info->stride[dim], gfc_index_zero_node);
3446 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3447 info->start[dim], end);
3448 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3451 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3453 stride_pos, stride_neg);
3455 /* Check the start of the range against the lower and upper
3456 bounds of the array, if the range is not empty.
3457 If upper bound is present, include both bounds in the
3461 tmp = fold_build2_loc (input_location, LT_EXPR,
3463 info->start[dim], lbound);
3464 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3466 non_zerosized, tmp);
3467 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3469 info->start[dim], ubound);
3470 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3472 non_zerosized, tmp2);
3473 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3474 "outside of expected range (%%ld:%%ld)",
3475 dim + 1, ss->expr->symtree->name);
3476 gfc_trans_runtime_check (true, false, tmp, &inner,
3477 &ss->expr->where, msg,
3478 fold_convert (long_integer_type_node, info->start[dim]),
3479 fold_convert (long_integer_type_node, lbound),
3480 fold_convert (long_integer_type_node, ubound));
3481 gfc_trans_runtime_check (true, false, tmp2, &inner,
3482 &ss->expr->where, msg,
3483 fold_convert (long_integer_type_node, info->start[dim]),
3484 fold_convert (long_integer_type_node, lbound),
3485 fold_convert (long_integer_type_node, ubound));
3490 tmp = fold_build2_loc (input_location, LT_EXPR,
3492 info->start[dim], lbound);
3493 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3494 boolean_type_node, non_zerosized, tmp);
3495 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3496 "below lower bound of %%ld",
3497 dim + 1, ss->expr->symtree->name);
3498 gfc_trans_runtime_check (true, false, tmp, &inner,
3499 &ss->expr->where, msg,
3500 fold_convert (long_integer_type_node, info->start[dim]),
3501 fold_convert (long_integer_type_node, lbound));
3505 /* Compute the last element of the range, which is not
3506 necessarily "end" (think 0:5:3, which doesn't contain 5)
3507 and check it against both lower and upper bounds. */
3509 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3510 gfc_array_index_type, end,
3512 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3513 gfc_array_index_type, tmp,
3515 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3516 gfc_array_index_type, end, tmp);
3517 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3518 boolean_type_node, tmp, lbound);
3519 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3520 boolean_type_node, non_zerosized, tmp2);
3523 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3524 boolean_type_node, tmp, ubound);
3525 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3526 boolean_type_node, non_zerosized, tmp3);
3527 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3528 "outside of expected range (%%ld:%%ld)",
3529 dim + 1, ss->expr->symtree->name);
3530 gfc_trans_runtime_check (true, false, tmp2, &inner,
3531 &ss->expr->where, msg,
3532 fold_convert (long_integer_type_node, tmp),
3533 fold_convert (long_integer_type_node, ubound),
3534 fold_convert (long_integer_type_node, lbound));
3535 gfc_trans_runtime_check (true, false, tmp3, &inner,
3536 &ss->expr->where, msg,
3537 fold_convert (long_integer_type_node, tmp),
3538 fold_convert (long_integer_type_node, ubound),
3539 fold_convert (long_integer_type_node, lbound));
3544 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3545 "below lower bound of %%ld",
3546 dim + 1, ss->expr->symtree->name);
3547 gfc_trans_runtime_check (true, false, tmp2, &inner,
3548 &ss->expr->where, msg,
3549 fold_convert (long_integer_type_node, tmp),
3550 fold_convert (long_integer_type_node, lbound));
3554 /* Check the section sizes match. */
3555 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3556 gfc_array_index_type, end,
3558 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3559 gfc_array_index_type, tmp,
3561 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3562 gfc_array_index_type,
3563 gfc_index_one_node, tmp);
3564 tmp = fold_build2_loc (input_location, MAX_EXPR,
3565 gfc_array_index_type, tmp,
3566 build_int_cst (gfc_array_index_type, 0));
3567 /* We remember the size of the first section, and check all the
3568 others against this. */
3571 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3572 boolean_type_node, tmp, size[n]);
3573 asprintf (&msg, "Array bound mismatch for dimension %d "
3574 "of array '%s' (%%ld/%%ld)",
3575 dim + 1, ss->expr->symtree->name);
3577 gfc_trans_runtime_check (true, false, tmp3, &inner,
3578 &ss->expr->where, msg,
3579 fold_convert (long_integer_type_node, tmp),
3580 fold_convert (long_integer_type_node, size[n]));
3585 size[n] = gfc_evaluate_now (tmp, &inner);
3588 tmp = gfc_finish_block (&inner);
3590 /* For optional arguments, only check bounds if the argument is
3592 if (ss->expr->symtree->n.sym->attr.optional
3593 || ss->expr->symtree->n.sym->attr.not_always_present)
3594 tmp = build3_v (COND_EXPR,
3595 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3596 tmp, build_empty_stmt (input_location));
3598 gfc_add_expr_to_block (&block, tmp);
3602 tmp = gfc_finish_block (&block);
3603 gfc_add_expr_to_block (&loop->pre, tmp);
3607 /* Return true if both symbols could refer to the same data object. Does
3608 not take account of aliasing due to equivalence statements. */
3611 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3612 bool lsym_target, bool rsym_pointer, bool rsym_target)
3614 /* Aliasing isn't possible if the symbols have different base types. */
3615 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3618 /* Pointers can point to other pointers and target objects. */
3620 if ((lsym_pointer && (rsym_pointer || rsym_target))
3621 || (rsym_pointer && (lsym_pointer || lsym_target)))
3624 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3625 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3627 if (lsym_target && rsym_target
3628 && ((lsym->attr.dummy && !lsym->attr.contiguous
3629 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3630 || (rsym->attr.dummy && !rsym->attr.contiguous
3631 && (!rsym->attr.dimension
3632 || rsym->as->type == AS_ASSUMED_SHAPE))))
3639 /* Return true if the two SS could be aliased, i.e. both point to the same data
3641 /* TODO: resolve aliases based on frontend expressions. */
3644 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3650 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3652 lsym = lss->expr->symtree->n.sym;
3653 rsym = rss->expr->symtree->n.sym;
3655 lsym_pointer = lsym->attr.pointer;
3656 lsym_target = lsym->attr.target;
3657 rsym_pointer = rsym->attr.pointer;
3658 rsym_target = rsym->attr.target;
3660 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3661 rsym_pointer, rsym_target))
3664 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3665 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3668 /* For derived types we must check all the component types. We can ignore
3669 array references as these will have the same base type as the previous
3671 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3673 if (lref->type != REF_COMPONENT)
3676 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3677 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3679 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3680 rsym_pointer, rsym_target))
3683 if ((lsym_pointer && (rsym_pointer || rsym_target))
3684 || (rsym_pointer && (lsym_pointer || lsym_target)))
3686 if (gfc_compare_types (&lref->u.c.component->ts,
3691 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3694 if (rref->type != REF_COMPONENT)
3697 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3698 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3700 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3701 lsym_pointer, lsym_target,
3702 rsym_pointer, rsym_target))
3705 if ((lsym_pointer && (rsym_pointer || rsym_target))
3706 || (rsym_pointer && (lsym_pointer || lsym_target)))
3708 if (gfc_compare_types (&lref->u.c.component->ts,
3709 &rref->u.c.sym->ts))
3711 if (gfc_compare_types (&lref->u.c.sym->ts,
3712 &rref->u.c.component->ts))
3714 if (gfc_compare_types (&lref->u.c.component->ts,
3715 &rref->u.c.component->ts))
3721 lsym_pointer = lsym->attr.pointer;
3722 lsym_target = lsym->attr.target;
3723 lsym_pointer = lsym->attr.pointer;
3724 lsym_target = lsym->attr.target;
3726 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3728 if (rref->type != REF_COMPONENT)
3731 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3732 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3734 if (symbols_could_alias (rref->u.c.sym, lsym,
3735 lsym_pointer, lsym_target,
3736 rsym_pointer, rsym_target))
3739 if ((lsym_pointer && (rsym_pointer || rsym_target))
3740 || (rsym_pointer && (lsym_pointer || lsym_target)))
3742 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3751 /* Resolve array data dependencies. Creates a temporary if required. */
3752 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3756 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3765 loop->temp_ss = NULL;
3767 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3769 if (ss->type != GFC_SS_SECTION)
3772 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3774 if (gfc_could_be_alias (dest, ss)
3775 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3783 lref = dest->expr->ref;
3784 rref = ss->expr->ref;
3786 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3791 for (i = 0; i < dest->data.info.dimen; i++)
3792 for (j = 0; j < ss->data.info.dimen; j++)
3794 && dest->data.info.dim[i] == ss->data.info.dim[j])
3796 /* If we don't access array elements in the same order,
3797 there is a dependency. */
3802 /* TODO : loop shifting. */
3805 /* Mark the dimensions for LOOP SHIFTING */
3806 for (n = 0; n < loop->dimen; n++)
3808 int dim = dest->data.info.dim[n];
3810 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3812 else if (! gfc_is_same_range (&lref->u.ar,
3813 &rref->u.ar, dim, 0))
3817 /* Put all the dimensions with dependencies in the
3820 for (n = 0; n < loop->dimen; n++)
3822 gcc_assert (loop->order[n] == n);
3824 loop->order[dim++] = n;
3826 for (n = 0; n < loop->dimen; n++)
3829 loop->order[dim++] = n;
3832 gcc_assert (dim == loop->dimen);
3843 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3844 if (GFC_ARRAY_TYPE_P (base_type)
3845 || GFC_DESCRIPTOR_TYPE_P (base_type))
3846 base_type = gfc_get_element_type (base_type);
3847 loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
3849 gfc_add_ss_to_loop (loop, loop->temp_ss);
3852 loop->temp_ss = NULL;
3856 /* Initialize the scalarization loop. Creates the loop variables. Determines
3857 the range of the loop variables. Creates a temporary if required.
3858 Calculates how to transform from loop variables to array indices for each
3859 expression. Also generates code for scalar expressions which have been
3860 moved outside the loop. */
3863 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3865 int n, dim, spec_dim;
3867 gfc_ss_info *specinfo;
3870 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3871 bool dynamic[GFC_MAX_DIMENSIONS];
3876 for (n = 0; n < loop->dimen; n++)
3880 /* We use one SS term, and use that to determine the bounds of the
3881 loop for this dimension. We try to pick the simplest term. */
3882 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3884 gfc_ss_type ss_type;
3887 if (ss_type == GFC_SS_SCALAR
3888 || ss_type == GFC_SS_TEMP
3889 || ss_type == GFC_SS_REFERENCE)
3892 info = &ss->data.info;
3895 if (loopspec[n] != NULL)
3897 specinfo = &loopspec[n]->data.info;
3898 spec_dim = specinfo->dim[n];
3902 /* Silence unitialized warnings. */
3909 gcc_assert (ss->shape[dim]);
3910 /* The frontend has worked out the size for us. */
3912 || !loopspec[n]->shape
3913 || !integer_zerop (specinfo->start[spec_dim]))
3914 /* Prefer zero-based descriptors if possible. */
3919 if (ss->type == GFC_SS_CONSTRUCTOR)
3921 gfc_constructor_base base;
3922 /* An unknown size constructor will always be rank one.
3923 Higher rank constructors will either have known shape,
3924 or still be wrapped in a call to reshape. */
3925 gcc_assert (loop->dimen == 1);
3927 /* Always prefer to use the constructor bounds if the size
3928 can be determined at compile time. Prefer not to otherwise,
3929 since the general case involves realloc, and it's better to
3930 avoid that overhead if possible. */
3931 base = ss->expr->value.constructor;
3932 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3933 if (!dynamic[n] || !loopspec[n])
3938 /* TODO: Pick the best bound if we have a choice between a
3939 function and something else. */
3940 if (ss->type == GFC_SS_FUNCTION)
3946 /* Avoid using an allocatable lhs in an assignment, since
3947 there might be a reallocation coming. */
3948 if (loopspec[n] && ss->is_alloc_lhs)
3951 if (ss->type != GFC_SS_SECTION)
3956 /* Criteria for choosing a loop specifier (most important first):
3957 doesn't need realloc
3963 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3964 || n >= loop->dimen)
3966 else if (integer_onep (info->stride[dim])
3967 && !integer_onep (specinfo->stride[spec_dim]))
3969 else if (INTEGER_CST_P (info->stride[dim])
3970 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3972 else if (INTEGER_CST_P (info->start[dim])
3973 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3975 /* We don't work out the upper bound.
3976 else if (INTEGER_CST_P (info->finish[n])
3977 && ! INTEGER_CST_P (specinfo->finish[n]))
3978 loopspec[n] = ss; */
3981 /* We should have found the scalarization loop specifier. If not,
3983 gcc_assert (loopspec[n]);
3985 info = &loopspec[n]->data.info;
3988 /* Set the extents of this range. */
3989 cshape = loopspec[n]->shape;
3990 if (cshape && INTEGER_CST_P (info->start[dim])
3991 && INTEGER_CST_P (info->stride[dim]))
3993 loop->from[n] = info->start[dim];
3994 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3995 mpz_sub_ui (i, i, 1);
3996 /* To = from + (size - 1) * stride. */
3997 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3998 if (!integer_onep (info->stride[dim]))
3999 tmp = fold_build2_loc (input_location, MULT_EXPR,
4000 gfc_array_index_type, tmp,
4002 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4003 gfc_array_index_type,
4004 loop->from[n], tmp);
4008 loop->from[n] = info->start[dim];
4009 switch (loopspec[n]->type)
4011 case GFC_SS_CONSTRUCTOR:
4012 /* The upper bound is calculated when we expand the
4014 gcc_assert (loop->to[n] == NULL_TREE);
4017 case GFC_SS_SECTION:
4018 /* Use the end expression if it exists and is not constant,
4019 so that it is only evaluated once. */
4020 loop->to[n] = info->end[dim];
4023 case GFC_SS_FUNCTION:
4024 /* The loop bound will be set when we generate the call. */
4025 gcc_assert (loop->to[n] == NULL_TREE);
4033 /* Transform everything so we have a simple incrementing variable. */
4034 if (n < loop->dimen && integer_onep (info->stride[dim]))
4035 info->delta[dim] = gfc_index_zero_node;
4036 else if (n < loop->dimen)
4038 /* Set the delta for this section. */
4039 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4040 /* Number of iterations is (end - start + step) / step.
4041 with start = 0, this simplifies to
4043 for (i = 0; i<=last; i++){...}; */
4044 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4045 gfc_array_index_type, loop->to[n],
4047 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4048 gfc_array_index_type, tmp, info->stride[dim]);
4049 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4050 tmp, build_int_cst (gfc_array_index_type, -1));
4051 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4052 /* Make the loop variable start at 0. */
4053 loop->from[n] = gfc_index_zero_node;
4057 /* Add all the scalar code that can be taken out of the loops.
4058 This may include calculating the loop bounds, so do it before
4059 allocating the temporary. */
4060 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4062 /* If we want a temporary then create it. */
4063 if (loop->temp_ss != NULL)
4065 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
4067 /* Make absolutely sure that this is a complete type. */
4068 if (loop->temp_ss->string_length)
4069 loop->temp_ss->data.temp.type
4070 = gfc_get_character_type_len_for_eltype
4071 (TREE_TYPE (loop->temp_ss->data.temp.type),
4072 loop->temp_ss->string_length);
4074 tmp = loop->temp_ss->data.temp.type;
4075 n = loop->temp_ss->data.temp.dimen;
4076 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
4077 loop->temp_ss->type = GFC_SS_SECTION;
4078 loop->temp_ss->data.info.dimen = n;
4080 gcc_assert (loop->temp_ss->data.info.dimen != 0);
4081 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
4082 loop->temp_ss->data.info.dim[n] = n;
4084 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4085 &loop->temp_ss->data.info, tmp, NULL_TREE,
4086 false, true, false, where);
4089 for (n = 0; n < loop->temp_dim; n++)
4090 loopspec[loop->order[n]] = NULL;
4094 /* For array parameters we don't have loop variables, so don't calculate the
4096 if (loop->array_parameter)
4099 /* Calculate the translation from loop variables to array indices. */
4100 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4102 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4103 && ss->type != GFC_SS_CONSTRUCTOR)
4107 info = &ss->data.info;
4109 for (n = 0; n < info->dimen; n++)
4111 /* If we are specifying the range the delta is already set. */
4112 if (loopspec[n] != ss)
4114 dim = ss->data.info.dim[n];
4116 /* Calculate the offset relative to the loop variable.
4117 First multiply by the stride. */
4118 tmp = loop->from[n];
4119 if (!integer_onep (info->stride[dim]))
4120 tmp = fold_build2_loc (input_location, MULT_EXPR,
4121 gfc_array_index_type,
4122 tmp, info->stride[dim]);
4124 /* Then subtract this from our starting value. */
4125 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4126 gfc_array_index_type,
4127 info->start[dim], tmp);
4129 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4136 /* Calculate the size of a given array dimension from the bounds. This
4137 is simply (ubound - lbound + 1) if this expression is positive
4138 or 0 if it is negative (pick either one if it is zero). Optionally
4139 (if or_expr is present) OR the (expression != 0) condition to it. */
4142 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4147 /* Calculate (ubound - lbound + 1). */
4148 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4150 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4151 gfc_index_one_node);
4153 /* Check whether the size for this dimension is negative. */
4154 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4155 gfc_index_zero_node);
4156 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4157 gfc_index_zero_node, res);
4159 /* Build OR expression. */
4161 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4162 boolean_type_node, *or_expr, cond);
4168 /* For an array descriptor, get the total number of elements. This is just
4169 the product of the extents along from_dim to to_dim. */
4172 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4177 res = gfc_index_one_node;
4179 for (dim = from_dim; dim < to_dim; ++dim)
4185 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4186 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4188 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4189 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4197 /* Full size of an array. */
4200 gfc_conv_descriptor_size (tree desc, int rank)
4202 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4206 /* Size of a coarray for all dimensions but the last. */
4209 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4211 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4215 /* Fills in an array descriptor, and returns the size of the array.
4216 The size will be a simple_val, ie a variable or a constant. Also
4217 calculates the offset of the base. The pointer argument overflow,
4218 which should be of integer type, will increase in value if overflow
4219 occurs during the size calculation. Returns the size of the array.
4223 for (n = 0; n < rank; n++)
4225 a.lbound[n] = specified_lower_bound;
4226 offset = offset + a.lbond[n] * stride;
4228 a.ubound[n] = specified_upper_bound;
4229 a.stride[n] = stride;
4230 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4231 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4232 stride = stride * size;
4234 for (n = rank; n < rank+corank; n++)
4235 (Set lcobound/ucobound as above.)
4236 element_size = sizeof (array element);
4239 stride = (size_t) stride;
4240 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4241 stride = stride * element_size;
4247 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4248 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4249 stmtblock_t * descriptor_block, tree * overflow)
4262 stmtblock_t thenblock;
4263 stmtblock_t elseblock;
4268 type = TREE_TYPE (descriptor);
4270 stride = gfc_index_one_node;
4271 offset = gfc_index_zero_node;
4273 /* Set the dtype. */
4274 tmp = gfc_conv_descriptor_dtype (descriptor);
4275 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4277 or_expr = boolean_false_node;
4279 for (n = 0; n < rank; n++)
4284 /* We have 3 possibilities for determining the size of the array:
4285 lower == NULL => lbound = 1, ubound = upper[n]
4286 upper[n] = NULL => lbound = 1, ubound = lower[n]
4287 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4290 /* Set lower bound. */
4291 gfc_init_se (&se, NULL);
4293 se.expr = gfc_index_one_node;
4296 gcc_assert (lower[n]);
4299 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4300 gfc_add_block_to_block (pblock, &se.pre);
4304 se.expr = gfc_index_one_node;
4308 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4309 gfc_rank_cst[n], se.expr);
4310 conv_lbound = se.expr;
4312 /* Work out the offset for this component. */
4313 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4315 offset = fold_build2_loc (input_location, MINUS_EXPR,
4316 gfc_array_index_type, offset, tmp);
4318 /* Set upper bound. */
4319 gfc_init_se (&se, NULL);
4320 gcc_assert (ubound);
4321 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4322 gfc_add_block_to_block (pblock, &se.pre);
4324 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4325 gfc_rank_cst[n], se.expr);
4326 conv_ubound = se.expr;
4328 /* Store the stride. */
4329 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4330 gfc_rank_cst[n], stride);
4332 /* Calculate size and check whether extent is negative. */
4333 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4334 size = gfc_evaluate_now (size, pblock);
4336 /* Check whether multiplying the stride by the number of
4337 elements in this dimension would overflow. We must also check
4338 whether the current dimension has zero size in order to avoid
4341 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4342 gfc_array_index_type,
4343 fold_convert (gfc_array_index_type,
4344 TYPE_MAX_VALUE (gfc_array_index_type)),
4346 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4347 boolean_type_node, tmp, stride));
4348 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4349 integer_one_node, integer_zero_node);
4350 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4351 boolean_type_node, size,
4352 gfc_index_zero_node));
4353 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4354 integer_zero_node, tmp);
4355 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4357 *overflow = gfc_evaluate_now (tmp, pblock);
4359 /* Multiply the stride by the number of elements in this dimension. */
4360 stride = fold_build2_loc (input_location, MULT_EXPR,
4361 gfc_array_index_type, stride, size);
4362 stride = gfc_evaluate_now (stride, pblock);
4365 for (n = rank; n < rank + corank; n++)
4369 /* Set lower bound. */
4370 gfc_init_se (&se, NULL);
4371 if (lower == NULL || lower[n] == NULL)
4373 gcc_assert (n == rank + corank - 1);
4374 se.expr = gfc_index_one_node;
4378 if (ubound || n == rank + corank - 1)
4380 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4381 gfc_add_block_to_block (pblock, &se.pre);
4385 se.expr = gfc_index_one_node;
4389 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4390 gfc_rank_cst[n], se.expr);
4392 if (n < rank + corank - 1)
4394 gfc_init_se (&se, NULL);
4395 gcc_assert (ubound);
4396 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4397 gfc_add_block_to_block (pblock, &se.pre);
4398 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4399 gfc_rank_cst[n], se.expr);
4403 /* The stride is the number of elements in the array, so multiply by the
4404 size of an element to get the total size. */
4405 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4406 /* Convert to size_t. */
4407 element_size = fold_convert (size_type_node, tmp);
4410 return element_size;
4412 stride = fold_convert (size_type_node, stride);
4414 /* First check for overflow. Since an array of type character can
4415 have zero element_size, we must check for that before
4417 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4419 TYPE_MAX_VALUE (size_type_node), element_size);
4420 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4421 boolean_type_node, tmp, stride));
4422 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4423 integer_one_node, integer_zero_node);
4424 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4425 boolean_type_node, element_size,
4426 build_int_cst (size_type_node, 0)));
4427 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4428 integer_zero_node, tmp);
4429 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4431 *overflow = gfc_evaluate_now (tmp, pblock);
4433 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4434 stride, element_size);
4436 if (poffset != NULL)
4438 offset = gfc_evaluate_now (offset, pblock);
4442 if (integer_zerop (or_expr))
4444 if (integer_onep (or_expr))
4445 return build_int_cst (size_type_node, 0);
4447 var = gfc_create_var (TREE_TYPE (size), "size");
4448 gfc_start_block (&thenblock);
4449 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4450 thencase = gfc_finish_block (&thenblock);
4452 gfc_start_block (&elseblock);
4453 gfc_add_modify (&elseblock, var, size);
4454 elsecase = gfc_finish_block (&elseblock);
4456 tmp = gfc_evaluate_now (or_expr, pblock);
4457 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4458 gfc_add_expr_to_block (pblock, tmp);
4464 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4465 the work for an ALLOCATE statement. */
4469 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4474 tree offset = NULL_TREE;
4475 tree token = NULL_TREE;
4478 tree error = NULL_TREE;
4479 tree overflow; /* Boolean storing whether size calculation overflows. */
4480 tree var_overflow = NULL_TREE;
4482 tree set_descriptor;
4483 stmtblock_t set_descriptor_block;
4484 stmtblock_t elseblock;
4487 gfc_ref *ref, *prev_ref = NULL;
4488 bool allocatable, coarray, dimension;
4492 /* Find the last reference in the chain. */
4493 while (ref && ref->next != NULL)
4495 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4496 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4501 if (ref == NULL || ref->type != REF_ARRAY)
4506 allocatable = expr->symtree->n.sym->attr.allocatable;
4507 coarray = expr->symtree->n.sym->attr.codimension;
4508 dimension = expr->symtree->n.sym->attr.dimension;
4512 allocatable = prev_ref->u.c.component->attr.allocatable;
4513 coarray = prev_ref->u.c.component->attr.codimension;
4514 dimension = prev_ref->u.c.component->attr.dimension;
4518 gcc_assert (coarray);
4520 /* Figure out the size of the array. */
4521 switch (ref->u.ar.type)
4527 upper = ref->u.ar.start;
4533 lower = ref->u.ar.start;
4534 upper = ref->u.ar.end;
4538 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4540 lower = ref->u.ar.as->lower;
4541 upper = ref->u.ar.as->upper;
4549 overflow = integer_zero_node;
4551 gfc_init_block (&set_descriptor_block);
4552 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4553 ref->u.ar.as->corank, &offset, lower, upper,
4554 &se->pre, &set_descriptor_block, &overflow);
4559 var_overflow = gfc_create_var (integer_type_node, "overflow");
4560 gfc_add_modify (&se->pre, var_overflow, overflow);
4562 /* Generate the block of code handling overflow. */
4563 msg = gfc_build_addr_expr (pchar_type_node,
4564 gfc_build_localized_cstring_const
4565 ("Integer overflow when calculating the amount of "
4566 "memory to allocate"));
4567 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4571 if (status != NULL_TREE)
4573 tree status_type = TREE_TYPE (status);
4574 stmtblock_t set_status_block;
4576 gfc_start_block (&set_status_block);
4577 gfc_add_modify (&set_status_block, status,
4578 build_int_cst (status_type, LIBERROR_ALLOCATION));
4579 error = gfc_finish_block (&set_status_block);
4582 gfc_start_block (&elseblock);
4584 /* Allocate memory to store the data. */
4585 pointer = gfc_conv_descriptor_data_get (se->expr);
4586 STRIP_NOPS (pointer);
4588 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4589 token = gfc_build_addr_expr (NULL_TREE,
4590 gfc_conv_descriptor_token (se->expr));
4592 /* The allocatable variant takes the old pointer as first argument. */
4594 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4595 status, errmsg, errlen, expr);
4597 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4601 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4602 boolean_type_node, var_overflow, integer_zero_node));
4603 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4604 error, gfc_finish_block (&elseblock));
4607 tmp = gfc_finish_block (&elseblock);
4609 gfc_add_expr_to_block (&se->pre, tmp);
4611 /* Update the array descriptors. */
4613 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4615 set_descriptor = gfc_finish_block (&set_descriptor_block);
4616 if (status != NULL_TREE)
4618 cond = fold_build2_loc (input_location, EQ_EXPR,
4619 boolean_type_node, status,
4620 build_int_cst (TREE_TYPE (status), 0));
4621 gfc_add_expr_to_block (&se->pre,
4622 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4623 gfc_likely (cond), set_descriptor,
4624 build_empty_stmt (input_location)));
4627 gfc_add_expr_to_block (&se->pre, set_descriptor);
4629 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4630 && expr->ts.u.derived->attr.alloc_comp)
4632 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4633 ref->u.ar.as->rank);
4634 gfc_add_expr_to_block (&se->pre, tmp);
4641 /* Deallocate an array variable. Also used when an allocated variable goes
4646 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4652 gfc_start_block (&block);
4653 /* Get a pointer to the data. */
4654 var = gfc_conv_descriptor_data_get (descriptor);
4657 /* Parameter is the address of the data component. */
4658 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4659 gfc_add_expr_to_block (&block, tmp);
4661 /* Zero the data pointer. */
4662 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4663 var, build_int_cst (TREE_TYPE (var), 0));
4664 gfc_add_expr_to_block (&block, tmp);
4666 return gfc_finish_block (&block);
4670 /* Create an array constructor from an initialization expression.
4671 We assume the frontend already did any expansions and conversions. */
4674 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4680 unsigned HOST_WIDE_INT lo;
4682 VEC(constructor_elt,gc) *v = NULL;
4684 switch (expr->expr_type)
4687 case EXPR_STRUCTURE:
4688 /* A single scalar or derived type value. Create an array with all
4689 elements equal to that value. */
4690 gfc_init_se (&se, NULL);
4692 if (expr->expr_type == EXPR_CONSTANT)
4693 gfc_conv_constant (&se, expr);
4695 gfc_conv_structure (&se, expr, 1);
4697 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4698 gcc_assert (tmp && INTEGER_CST_P (tmp));
4699 hi = TREE_INT_CST_HIGH (tmp);
4700 lo = TREE_INT_CST_LOW (tmp);
4704 /* This will probably eat buckets of memory for large arrays. */
4705 while (hi != 0 || lo != 0)
4707 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4715 /* Create a vector of all the elements. */
4716 for (c = gfc_constructor_first (expr->value.constructor);
4717 c; c = gfc_constructor_next (c))
4721 /* Problems occur when we get something like
4722 integer :: a(lots) = (/(i, i=1, lots)/) */
4723 gfc_fatal_error ("The number of elements in the array constructor "
4724 "at %L requires an increase of the allowed %d "
4725 "upper limit. See -fmax-array-constructor "
4726 "option", &expr->where,
4727 gfc_option.flag_max_array_constructor);
4730 if (mpz_cmp_si (c->offset, 0) != 0)
4731 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4735 if (mpz_cmp_si (c->repeat, 1) > 0)
4741 mpz_add (maxval, c->offset, c->repeat);
4742 mpz_sub_ui (maxval, maxval, 1);
4743 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4744 if (mpz_cmp_si (c->offset, 0) != 0)
4746 mpz_add_ui (maxval, c->offset, 1);
4747 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4750 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4752 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4758 gfc_init_se (&se, NULL);
4759 switch (c->expr->expr_type)
4762 gfc_conv_constant (&se, c->expr);
4765 case EXPR_STRUCTURE:
4766 gfc_conv_structure (&se, c->expr, 1);
4770 /* Catch those occasional beasts that do not simplify
4771 for one reason or another, assuming that if they are
4772 standard defying the frontend will catch them. */
4773 gfc_conv_expr (&se, c->expr);
4777 if (range == NULL_TREE)
4778 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4781 if (index != NULL_TREE)
4782 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4783 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4789 return gfc_build_null_descriptor (type);
4795 /* Create a constructor from the list of elements. */
4796 tmp = build_constructor (type, v);
4797 TREE_CONSTANT (tmp) = 1;
4802 /* Generate code to evaluate non-constant coarray cobounds. */
4805 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4806 const gfc_symbol *sym)
4816 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4818 /* Evaluate non-constant array bound expressions. */
4819 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4820 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4822 gfc_init_se (&se, NULL);
4823 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4824 gfc_add_block_to_block (pblock, &se.pre);
4825 gfc_add_modify (pblock, lbound, se.expr);
4827 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4828 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4830 gfc_init_se (&se, NULL);
4831 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4832 gfc_add_block_to_block (pblock, &se.pre);
4833 gfc_add_modify (pblock, ubound, se.expr);
4839 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4840 returns the size (in elements) of the array. */
4843 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4844 stmtblock_t * pblock)
4859 size = gfc_index_one_node;
4860 offset = gfc_index_zero_node;
4861 for (dim = 0; dim < as->rank; dim++)
4863 /* Evaluate non-constant array bound expressions. */
4864 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4865 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4867 gfc_init_se (&se, NULL);
4868 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4869 gfc_add_block_to_block (pblock, &se.pre);
4870 gfc_add_modify (pblock, lbound, se.expr);
4872 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4873 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4875 gfc_init_se (&se, NULL);
4876 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4877 gfc_add_block_to_block (pblock, &se.pre);
4878 gfc_add_modify (pblock, ubound, se.expr);
4880 /* The offset of this dimension. offset = offset - lbound * stride. */
4881 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4883 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4886 /* The size of this dimension, and the stride of the next. */
4887 if (dim + 1 < as->rank)
4888 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4890 stride = GFC_TYPE_ARRAY_SIZE (type);
4892 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4894 /* Calculate stride = size * (ubound + 1 - lbound). */
4895 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4896 gfc_array_index_type,
4897 gfc_index_one_node, lbound);
4898 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4899 gfc_array_index_type, ubound, tmp);
4900 tmp = fold_build2_loc (input_location, MULT_EXPR,
4901 gfc_array_index_type, size, tmp);
4903 gfc_add_modify (pblock, stride, tmp);
4905 stride = gfc_evaluate_now (tmp, pblock);
4907 /* Make sure that negative size arrays are translated
4908 to being zero size. */
4909 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4910 stride, gfc_index_zero_node);
4911 tmp = fold_build3_loc (input_location, COND_EXPR,
4912 gfc_array_index_type, tmp,
4913 stride, gfc_index_zero_node);
4914 gfc_add_modify (pblock, stride, tmp);
4920 gfc_trans_array_cobounds (type, pblock, sym);
4921 gfc_trans_vla_type_sizes (sym, pblock);
4928 /* Generate code to initialize/allocate an array variable. */
4931 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4932 gfc_wrapped_block * block)
4936 tree tmp = NULL_TREE;
4943 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4945 /* Do nothing for USEd variables. */
4946 if (sym->attr.use_assoc)
4949 type = TREE_TYPE (decl);
4950 gcc_assert (GFC_ARRAY_TYPE_P (type));
4951 onstack = TREE_CODE (type) != POINTER_TYPE;
4953 gfc_init_block (&init);
4955 /* Evaluate character string length. */
4956 if (sym->ts.type == BT_CHARACTER
4957 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4959 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4961 gfc_trans_vla_type_sizes (sym, &init);
4963 /* Emit a DECL_EXPR for this variable, which will cause the
4964 gimplifier to allocate storage, and all that good stuff. */
4965 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4966 gfc_add_expr_to_block (&init, tmp);
4971 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4975 type = TREE_TYPE (type);
4977 gcc_assert (!sym->attr.use_assoc);
4978 gcc_assert (!TREE_STATIC (decl));
4979 gcc_assert (!sym->module);
4981 if (sym->ts.type == BT_CHARACTER
4982 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4983 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4985 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4987 /* Don't actually allocate space for Cray Pointees. */
4988 if (sym->attr.cray_pointee)
4990 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4991 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4993 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4997 if (gfc_option.flag_stack_arrays)
4999 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5000 space = build_decl (sym->declared_at.lb->location,
5001 VAR_DECL, create_tmp_var_name ("A"),
5002 TREE_TYPE (TREE_TYPE (decl)));
5003 gfc_trans_vla_type_sizes (sym, &init);
5007 /* The size is the number of elements in the array, so multiply by the
5008 size of an element to get the total size. */
5009 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5010 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5011 size, fold_convert (gfc_array_index_type, tmp));
5013 /* Allocate memory to hold the data. */
5014 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5015 gfc_add_modify (&init, decl, tmp);
5017 /* Free the temporary. */
5018 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5022 /* Set offset of the array. */
5023 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5024 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5026 /* Automatic arrays should not have initializers. */
5027 gcc_assert (!sym->value);
5029 inittree = gfc_finish_block (&init);
5036 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5037 where also space is located. */
5038 gfc_init_block (&init);
5039 tmp = fold_build1_loc (input_location, DECL_EXPR,
5040 TREE_TYPE (space), space);
5041 gfc_add_expr_to_block (&init, tmp);
5042 addr = fold_build1_loc (sym->declared_at.lb->location,
5043 ADDR_EXPR, TREE_TYPE (decl), space);
5044 gfc_add_modify (&init, decl, addr);
5045 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5048 gfc_add_init_cleanup (block, inittree, tmp);
5052 /* Generate entry and exit code for g77 calling convention arrays. */
5055 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5065 gfc_save_backend_locus (&loc);
5066 gfc_set_backend_locus (&sym->declared_at);
5068 /* Descriptor type. */
5069 parm = sym->backend_decl;
5070 type = TREE_TYPE (parm);
5071 gcc_assert (GFC_ARRAY_TYPE_P (type));
5073 gfc_start_block (&init);
5075 if (sym->ts.type == BT_CHARACTER
5076 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5077 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5079 /* Evaluate the bounds of the array. */
5080 gfc_trans_array_bounds (type, sym, &offset, &init);
5082 /* Set the offset. */
5083 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5084 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5086 /* Set the pointer itself if we aren't using the parameter directly. */
5087 if (TREE_CODE (parm) != PARM_DECL)
5089 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5090 gfc_add_modify (&init, parm, tmp);
5092 stmt = gfc_finish_block (&init);
5094 gfc_restore_backend_locus (&loc);
5096 /* Add the initialization code to the start of the function. */
5098 if (sym->attr.optional || sym->attr.not_always_present)
5100 tmp = gfc_conv_expr_present (sym);
5101 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5104 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5108 /* Modify the descriptor of an array parameter so that it has the
5109 correct lower bound. Also move the upper bound accordingly.
5110 If the array is not packed, it will be copied into a temporary.
5111 For each dimension we set the new lower and upper bounds. Then we copy the
5112 stride and calculate the offset for this dimension. We also work out
5113 what the stride of a packed array would be, and see it the two match.
5114 If the array need repacking, we set the stride to the values we just
5115 calculated, recalculate the offset and copy the array data.
5116 Code is also added to copy the data back at the end of the function.
5120 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5121 gfc_wrapped_block * block)
5128 tree stmtInit, stmtCleanup;
5135 tree stride, stride2;
5145 /* Do nothing for pointer and allocatable arrays. */
5146 if (sym->attr.pointer || sym->attr.allocatable)
5149 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5151 gfc_trans_g77_array (sym, block);
5155 gfc_save_backend_locus (&loc);
5156 gfc_set_backend_locus (&sym->declared_at);
5158 /* Descriptor type. */
5159 type = TREE_TYPE (tmpdesc);
5160 gcc_assert (GFC_ARRAY_TYPE_P (type));
5161 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5162 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5163 gfc_start_block (&init);
5165 if (sym->ts.type == BT_CHARACTER
5166 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5167 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5169 checkparm = (sym->as->type == AS_EXPLICIT
5170 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5172 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5173 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5175 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5177 /* For non-constant shape arrays we only check if the first dimension
5178 is contiguous. Repacking higher dimensions wouldn't gain us
5179 anything as we still don't know the array stride. */
5180 partial = gfc_create_var (boolean_type_node, "partial");
5181 TREE_USED (partial) = 1;
5182 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5183 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5184 gfc_index_one_node);
5185 gfc_add_modify (&init, partial, tmp);
5188 partial = NULL_TREE;
5190 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5191 here, however I think it does the right thing. */
5194 /* Set the first stride. */
5195 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5196 stride = gfc_evaluate_now (stride, &init);
5198 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5199 stride, gfc_index_zero_node);
5200 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5201 tmp, gfc_index_one_node, stride);
5202 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5203 gfc_add_modify (&init, stride, tmp);
5205 /* Allow the user to disable array repacking. */
5206 stmt_unpacked = NULL_TREE;
5210 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5211 /* A library call to repack the array if necessary. */
5212 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5213 stmt_unpacked = build_call_expr_loc (input_location,
5214 gfor_fndecl_in_pack, 1, tmp);
5216 stride = gfc_index_one_node;
5218 if (gfc_option.warn_array_temp)
5219 gfc_warning ("Creating array temporary at %L", &loc);
5222 /* This is for the case where the array data is used directly without
5223 calling the repack function. */
5224 if (no_repack || partial != NULL_TREE)
5225 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5227 stmt_packed = NULL_TREE;
5229 /* Assign the data pointer. */
5230 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5232 /* Don't repack unknown shape arrays when the first stride is 1. */
5233 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5234 partial, stmt_packed, stmt_unpacked);
5237 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5238 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5240 offset = gfc_index_zero_node;
5241 size = gfc_index_one_node;
5243 /* Evaluate the bounds of the array. */
5244 for (n = 0; n < sym->as->rank; n++)
5246 if (checkparm || !sym->as->upper[n])
5248 /* Get the bounds of the actual parameter. */
5249 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5250 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5254 dubound = NULL_TREE;
5255 dlbound = NULL_TREE;
5258 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5259 if (!INTEGER_CST_P (lbound))
5261 gfc_init_se (&se, NULL);
5262 gfc_conv_expr_type (&se, sym->as->lower[n],
5263 gfc_array_index_type);
5264 gfc_add_block_to_block (&init, &se.pre);
5265 gfc_add_modify (&init, lbound, se.expr);
5268 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5269 /* Set the desired upper bound. */
5270 if (sym->as->upper[n])
5272 /* We know what we want the upper bound to be. */
5273 if (!INTEGER_CST_P (ubound))
5275 gfc_init_se (&se, NULL);
5276 gfc_conv_expr_type (&se, sym->as->upper[n],
5277 gfc_array_index_type);
5278 gfc_add_block_to_block (&init, &se.pre);
5279 gfc_add_modify (&init, ubound, se.expr);
5282 /* Check the sizes match. */
5285 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5289 temp = fold_build2_loc (input_location, MINUS_EXPR,
5290 gfc_array_index_type, ubound, lbound);
5291 temp = fold_build2_loc (input_location, PLUS_EXPR,
5292 gfc_array_index_type,
5293 gfc_index_one_node, temp);
5294 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5295 gfc_array_index_type, dubound,
5297 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5298 gfc_array_index_type,
5299 gfc_index_one_node, stride2);
5300 tmp = fold_build2_loc (input_location, NE_EXPR,
5301 gfc_array_index_type, temp, stride2);
5302 asprintf (&msg, "Dimension %d of array '%s' has extent "
5303 "%%ld instead of %%ld", n+1, sym->name);
5305 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5306 fold_convert (long_integer_type_node, temp),
5307 fold_convert (long_integer_type_node, stride2));
5314 /* For assumed shape arrays move the upper bound by the same amount
5315 as the lower bound. */
5316 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5317 gfc_array_index_type, dubound, dlbound);
5318 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5319 gfc_array_index_type, tmp, lbound);
5320 gfc_add_modify (&init, ubound, tmp);
5322 /* The offset of this dimension. offset = offset - lbound * stride. */
5323 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5325 offset = fold_build2_loc (input_location, MINUS_EXPR,
5326 gfc_array_index_type, offset, tmp);
5328 /* The size of this dimension, and the stride of the next. */
5329 if (n + 1 < sym->as->rank)
5331 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5333 if (no_repack || partial != NULL_TREE)
5335 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5337 /* Figure out the stride if not a known constant. */
5338 if (!INTEGER_CST_P (stride))
5341 stmt_packed = NULL_TREE;
5344 /* Calculate stride = size * (ubound + 1 - lbound). */
5345 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5346 gfc_array_index_type,
5347 gfc_index_one_node, lbound);
5348 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5349 gfc_array_index_type, ubound, tmp);
5350 size = fold_build2_loc (input_location, MULT_EXPR,
5351 gfc_array_index_type, size, tmp);
5355 /* Assign the stride. */
5356 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5357 tmp = fold_build3_loc (input_location, COND_EXPR,
5358 gfc_array_index_type, partial,
5359 stmt_unpacked, stmt_packed);
5361 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5362 gfc_add_modify (&init, stride, tmp);
5367 stride = GFC_TYPE_ARRAY_SIZE (type);
5369 if (stride && !INTEGER_CST_P (stride))
5371 /* Calculate size = stride * (ubound + 1 - lbound). */
5372 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5373 gfc_array_index_type,
5374 gfc_index_one_node, lbound);
5375 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5376 gfc_array_index_type,
5378 tmp = fold_build2_loc (input_location, MULT_EXPR,
5379 gfc_array_index_type,
5380 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5381 gfc_add_modify (&init, stride, tmp);
5386 gfc_trans_array_cobounds (type, &init, sym);
5388 /* Set the offset. */
5389 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5390 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5392 gfc_trans_vla_type_sizes (sym, &init);
5394 stmtInit = gfc_finish_block (&init);
5396 /* Only do the entry/initialization code if the arg is present. */
5397 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5398 optional_arg = (sym->attr.optional
5399 || (sym->ns->proc_name->attr.entry_master
5400 && sym->attr.dummy));
5403 tmp = gfc_conv_expr_present (sym);
5404 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5405 build_empty_stmt (input_location));
5410 stmtCleanup = NULL_TREE;
5413 stmtblock_t cleanup;
5414 gfc_start_block (&cleanup);
5416 if (sym->attr.intent != INTENT_IN)
5418 /* Copy the data back. */
5419 tmp = build_call_expr_loc (input_location,
5420 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5421 gfc_add_expr_to_block (&cleanup, tmp);
5424 /* Free the temporary. */
5425 tmp = gfc_call_free (tmpdesc);
5426 gfc_add_expr_to_block (&cleanup, tmp);
5428 stmtCleanup = gfc_finish_block (&cleanup);
5430 /* Only do the cleanup if the array was repacked. */
5431 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5432 tmp = gfc_conv_descriptor_data_get (tmp);
5433 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5435 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5436 build_empty_stmt (input_location));
5440 tmp = gfc_conv_expr_present (sym);
5441 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5442 build_empty_stmt (input_location));
5446 /* We don't need to free any memory allocated by internal_pack as it will
5447 be freed at the end of the function by pop_context. */
5448 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5450 gfc_restore_backend_locus (&loc);
5454 /* Calculate the overall offset, including subreferences. */
5456 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5457 bool subref, gfc_expr *expr)
5467 /* If offset is NULL and this is not a subreferenced array, there is
5469 if (offset == NULL_TREE)
5472 offset = gfc_index_zero_node;
5477 tmp = gfc_conv_array_data (desc);
5478 tmp = build_fold_indirect_ref_loc (input_location,
5480 tmp = gfc_build_array_ref (tmp, offset, NULL);
5482 /* Offset the data pointer for pointer assignments from arrays with
5483 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5486 /* Go past the array reference. */
5487 for (ref = expr->ref; ref; ref = ref->next)
5488 if (ref->type == REF_ARRAY &&
5489 ref->u.ar.type != AR_ELEMENT)
5495 /* Calculate the offset for each subsequent subreference. */
5496 for (; ref; ref = ref->next)
5501 field = ref->u.c.component->backend_decl;
5502 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5503 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5505 tmp, field, NULL_TREE);
5509 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5510 gfc_init_se (&start, NULL);
5511 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5512 gfc_add_block_to_block (block, &start.pre);
5513 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5517 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5518 && ref->u.ar.type == AR_ELEMENT);
5520 /* TODO - Add bounds checking. */
5521 stride = gfc_index_one_node;
5522 index = gfc_index_zero_node;
5523 for (n = 0; n < ref->u.ar.dimen; n++)
5528 /* Update the index. */
5529 gfc_init_se (&start, NULL);
5530 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5531 itmp = gfc_evaluate_now (start.expr, block);
5532 gfc_init_se (&start, NULL);
5533 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5534 jtmp = gfc_evaluate_now (start.expr, block);
5535 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5536 gfc_array_index_type, itmp, jtmp);
5537 itmp = fold_build2_loc (input_location, MULT_EXPR,
5538 gfc_array_index_type, itmp, stride);
5539 index = fold_build2_loc (input_location, PLUS_EXPR,
5540 gfc_array_index_type, itmp, index);
5541 index = gfc_evaluate_now (index, block);
5543 /* Update the stride. */
5544 gfc_init_se (&start, NULL);
5545 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5546 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5547 gfc_array_index_type, start.expr,
5549 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5550 gfc_array_index_type,
5551 gfc_index_one_node, itmp);
5552 stride = fold_build2_loc (input_location, MULT_EXPR,
5553 gfc_array_index_type, stride, itmp);
5554 stride = gfc_evaluate_now (stride, block);
5557 /* Apply the index to obtain the array element. */
5558 tmp = gfc_build_array_ref (tmp, index, NULL);
5568 /* Set the target data pointer. */
5569 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5570 gfc_conv_descriptor_data_set (block, parm, offset);
5574 /* gfc_conv_expr_descriptor needs the string length an expression
5575 so that the size of the temporary can be obtained. This is done
5576 by adding up the string lengths of all the elements in the
5577 expression. Function with non-constant expressions have their
5578 string lengths mapped onto the actual arguments using the
5579 interface mapping machinery in trans-expr.c. */
5581 get_array_charlen (gfc_expr *expr, gfc_se *se)
5583 gfc_interface_mapping mapping;
5584 gfc_formal_arglist *formal;
5585 gfc_actual_arglist *arg;
5588 if (expr->ts.u.cl->length
5589 && gfc_is_constant_expr (expr->ts.u.cl->length))
5591 if (!expr->ts.u.cl->backend_decl)
5592 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5596 switch (expr->expr_type)
5599 get_array_charlen (expr->value.op.op1, se);
5601 /* For parentheses the expression ts.u.cl is identical. */
5602 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5605 expr->ts.u.cl->backend_decl =
5606 gfc_create_var (gfc_charlen_type_node, "sln");
5608 if (expr->value.op.op2)
5610 get_array_charlen (expr->value.op.op2, se);
5612 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5614 /* Add the string lengths and assign them to the expression
5615 string length backend declaration. */
5616 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5617 fold_build2_loc (input_location, PLUS_EXPR,
5618 gfc_charlen_type_node,
5619 expr->value.op.op1->ts.u.cl->backend_decl,
5620 expr->value.op.op2->ts.u.cl->backend_decl));
5623 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5624 expr->value.op.op1->ts.u.cl->backend_decl);
5628 if (expr->value.function.esym == NULL
5629 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5631 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5635 /* Map expressions involving the dummy arguments onto the actual
5636 argument expressions. */
5637 gfc_init_interface_mapping (&mapping);
5638 formal = expr->symtree->n.sym->formal;
5639 arg = expr->value.function.actual;
5641 /* Set se = NULL in the calls to the interface mapping, to suppress any
5643 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5648 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5651 gfc_init_se (&tse, NULL);
5653 /* Build the expression for the character length and convert it. */
5654 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5656 gfc_add_block_to_block (&se->pre, &tse.pre);
5657 gfc_add_block_to_block (&se->post, &tse.post);
5658 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5659 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5660 gfc_charlen_type_node, tse.expr,
5661 build_int_cst (gfc_charlen_type_node, 0));
5662 expr->ts.u.cl->backend_decl = tse.expr;
5663 gfc_free_interface_mapping (&mapping);
5667 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5672 /* Helper function to check dimensions. */
5674 dim_ok (gfc_ss_info *info)
5677 for (n = 0; n < info->dimen; n++)
5678 if (info->dim[n] != n)
5683 /* Convert an array for passing as an actual argument. Expressions and
5684 vector subscripts are evaluated and stored in a temporary, which is then
5685 passed. For whole arrays the descriptor is passed. For array sections
5686 a modified copy of the descriptor is passed, but using the original data.
5688 This function is also used for array pointer assignments, and there
5691 - se->want_pointer && !se->direct_byref
5692 EXPR is an actual argument. On exit, se->expr contains a
5693 pointer to the array descriptor.
5695 - !se->want_pointer && !se->direct_byref
5696 EXPR is an actual argument to an intrinsic function or the
5697 left-hand side of a pointer assignment. On exit, se->expr
5698 contains the descriptor for EXPR.
5700 - !se->want_pointer && se->direct_byref
5701 EXPR is the right-hand side of a pointer assignment and
5702 se->expr is the descriptor for the previously-evaluated
5703 left-hand side. The function creates an assignment from
5707 The se->force_tmp flag disables the non-copying descriptor optimization
5708 that is used for transpose. It may be used in cases where there is an
5709 alias between the transpose argument and another argument in the same
5713 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5725 bool subref_array_target = false;
5728 gcc_assert (ss != NULL);
5729 gcc_assert (ss != gfc_ss_terminator);
5731 /* Special case things we know we can pass easily. */
5732 switch (expr->expr_type)
5735 /* If we have a linear array section, we can pass it directly.
5736 Otherwise we need to copy it into a temporary. */
5738 gcc_assert (ss->type == GFC_SS_SECTION);
5739 gcc_assert (ss->expr == expr);
5740 info = &ss->data.info;
5742 /* Get the descriptor for the array. */
5743 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5744 desc = info->descriptor;
5746 subref_array_target = se->direct_byref && is_subref_array (expr);
5747 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5748 && !subref_array_target;
5755 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5757 /* Create a new descriptor if the array doesn't have one. */
5760 else if (info->ref->u.ar.type == AR_FULL)
5762 else if (se->direct_byref)
5765 full = gfc_full_array_ref_p (info->ref, NULL);
5767 if (full && dim_ok (info))
5769 if (se->direct_byref && !se->byref_noassign)
5771 /* Copy the descriptor for pointer assignments. */
5772 gfc_add_modify (&se->pre, se->expr, desc);
5774 /* Add any offsets from subreferences. */
5775 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5776 subref_array_target, expr);
5778 else if (se->want_pointer)
5780 /* We pass full arrays directly. This means that pointers and
5781 allocatable arrays should also work. */
5782 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5789 if (expr->ts.type == BT_CHARACTER)
5790 se->string_length = gfc_get_expr_charlen (expr);
5798 /* We don't need to copy data in some cases. */
5799 arg = gfc_get_noncopying_intrinsic_argument (expr);
5802 /* This is a call to transpose... */
5803 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5804 /* ... which has already been handled by the scalarizer, so
5805 that we just need to get its argument's descriptor. */
5806 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5810 /* A transformational function return value will be a temporary
5811 array descriptor. We still need to go through the scalarizer
5812 to create the descriptor. Elemental functions ar handled as
5813 arbitrary expressions, i.e. copy to a temporary. */
5815 if (se->direct_byref)
5817 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5819 /* For pointer assignments pass the descriptor directly. */
5823 gcc_assert (se->ss == ss);
5824 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5825 gfc_conv_expr (se, expr);
5829 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5831 if (ss->expr != expr)
5832 /* Elemental function. */
5833 gcc_assert ((expr->value.function.esym != NULL
5834 && expr->value.function.esym->attr.elemental)
5835 || (expr->value.function.isym != NULL
5836 && expr->value.function.isym->elemental));
5838 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5841 if (expr->ts.type == BT_CHARACTER
5842 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5843 get_array_charlen (expr, se);
5849 /* Transformational function. */
5850 info = &ss->data.info;
5856 /* Constant array constructors don't need a temporary. */
5857 if (ss->type == GFC_SS_CONSTRUCTOR
5858 && expr->ts.type != BT_CHARACTER
5859 && gfc_constant_array_constructor_p (expr->value.constructor))
5862 info = &ss->data.info;
5872 /* Something complicated. Copy it into a temporary. */
5878 /* If we are creating a temporary, we don't need to bother about aliases
5883 gfc_init_loopinfo (&loop);
5885 /* Associate the SS with the loop. */
5886 gfc_add_ss_to_loop (&loop, ss);
5888 /* Tell the scalarizer not to bother creating loop variables, etc. */
5890 loop.array_parameter = 1;
5892 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5893 gcc_assert (!se->direct_byref);
5895 /* Setup the scalarizing loops and bounds. */
5896 gfc_conv_ss_startstride (&loop);
5900 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5901 get_array_charlen (expr, se);
5903 /* Tell the scalarizer to make a temporary. */
5904 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
5905 ((expr->ts.type == BT_CHARACTER)
5906 ? expr->ts.u.cl->backend_decl
5910 se->string_length = loop.temp_ss->string_length;
5911 gcc_assert (loop.temp_ss->data.temp.dimen == loop.dimen);
5912 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5915 gfc_conv_loop_setup (&loop, & expr->where);
5919 /* Copy into a temporary and pass that. We don't need to copy the data
5920 back because expressions and vector subscripts must be INTENT_IN. */
5921 /* TODO: Optimize passing function return values. */
5925 /* Start the copying loops. */
5926 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5927 gfc_mark_ss_chain_used (ss, 1);
5928 gfc_start_scalarized_body (&loop, &block);
5930 /* Copy each data element. */
5931 gfc_init_se (&lse, NULL);
5932 gfc_copy_loopinfo_to_se (&lse, &loop);
5933 gfc_init_se (&rse, NULL);
5934 gfc_copy_loopinfo_to_se (&rse, &loop);
5936 lse.ss = loop.temp_ss;
5939 gfc_conv_scalarized_array_ref (&lse, NULL);
5940 if (expr->ts.type == BT_CHARACTER)
5942 gfc_conv_expr (&rse, expr);
5943 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5944 rse.expr = build_fold_indirect_ref_loc (input_location,
5948 gfc_conv_expr_val (&rse, expr);
5950 gfc_add_block_to_block (&block, &rse.pre);
5951 gfc_add_block_to_block (&block, &lse.pre);
5953 lse.string_length = rse.string_length;
5954 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5955 expr->expr_type == EXPR_VARIABLE
5956 || expr->expr_type == EXPR_ARRAY, true);
5957 gfc_add_expr_to_block (&block, tmp);
5959 /* Finish the copying loops. */
5960 gfc_trans_scalarizing_loops (&loop, &block);
5962 desc = loop.temp_ss->data.info.descriptor;
5964 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5966 desc = info->descriptor;
5967 se->string_length = ss->string_length;
5971 /* We pass sections without copying to a temporary. Make a new
5972 descriptor and point it at the section we want. The loop variable
5973 limits will be the limits of the section.
5974 A function may decide to repack the array to speed up access, but
5975 we're not bothered about that here. */
5976 int dim, ndim, codim;
5984 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5986 if (se->want_coarray)
5988 gfc_array_ref *ar = &info->ref->u.ar;
5990 codim = gfc_get_corank (expr);
5991 for (n = 0; n < codim - 1; n++)
5993 /* Make sure we are not lost somehow. */
5994 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
5996 /* Make sure the call to gfc_conv_section_startstride won't
5997 generate unnecessary code to calculate stride. */
5998 gcc_assert (ar->stride[n + ndim] == NULL);
6000 gfc_conv_section_startstride (&loop, ss, n + ndim);
6001 loop.from[n + loop.dimen] = info->start[n + ndim];
6002 loop.to[n + loop.dimen] = info->end[n + ndim];
6005 gcc_assert (n == codim - 1);
6006 evaluate_bound (&loop.pre, info->start, ar->start,
6007 info->descriptor, n + ndim, true);
6008 loop.from[n + loop.dimen] = info->start[n + ndim];
6013 /* Set the string_length for a character array. */
6014 if (expr->ts.type == BT_CHARACTER)
6015 se->string_length = gfc_get_expr_charlen (expr);
6017 desc = info->descriptor;
6018 if (se->direct_byref && !se->byref_noassign)
6020 /* For pointer assignments we fill in the destination. */
6022 parmtype = TREE_TYPE (parm);
6026 /* Otherwise make a new one. */
6027 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6028 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6029 loop.from, loop.to, 0,
6030 GFC_ARRAY_UNKNOWN, false);
6031 parm = gfc_create_var (parmtype, "parm");
6034 offset = gfc_index_zero_node;
6036 /* The following can be somewhat confusing. We have two
6037 descriptors, a new one and the original array.
6038 {parm, parmtype, dim} refer to the new one.
6039 {desc, type, n, loop} refer to the original, which maybe
6040 a descriptorless array.
6041 The bounds of the scalarization are the bounds of the section.
6042 We don't have to worry about numeric overflows when calculating
6043 the offsets because all elements are within the array data. */
6045 /* Set the dtype. */
6046 tmp = gfc_conv_descriptor_dtype (parm);
6047 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6049 /* Set offset for assignments to pointer only to zero if it is not
6051 if (se->direct_byref
6052 && info->ref && info->ref->u.ar.type != AR_FULL)
6053 base = gfc_index_zero_node;
6054 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6055 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6059 for (n = 0; n < ndim; n++)
6061 stride = gfc_conv_array_stride (desc, n);
6063 /* Work out the offset. */
6065 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6067 gcc_assert (info->subscript[n]
6068 && info->subscript[n]->type == GFC_SS_SCALAR);
6069 start = info->subscript[n]->data.scalar.expr;
6073 /* Evaluate and remember the start of the section. */
6074 start = info->start[n];
6075 stride = gfc_evaluate_now (stride, &loop.pre);
6078 tmp = gfc_conv_array_lbound (desc, n);
6079 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6081 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6083 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6087 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6089 /* For elemental dimensions, we only need the offset. */
6093 /* Vector subscripts need copying and are handled elsewhere. */
6095 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6097 /* look for the corresponding scalarizer dimension: dim. */
6098 for (dim = 0; dim < ndim; dim++)
6099 if (info->dim[dim] == n)
6102 /* loop exited early: the DIM being looked for has been found. */
6103 gcc_assert (dim < ndim);
6105 /* Set the new lower bound. */
6106 from = loop.from[dim];
6109 /* If we have an array section or are assigning make sure that
6110 the lower bound is 1. References to the full
6111 array should otherwise keep the original bounds. */
6113 || info->ref->u.ar.type != AR_FULL)
6114 && !integer_onep (from))
6116 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6117 gfc_array_index_type, gfc_index_one_node,
6119 to = fold_build2_loc (input_location, PLUS_EXPR,
6120 gfc_array_index_type, to, tmp);
6121 from = gfc_index_one_node;
6123 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6124 gfc_rank_cst[dim], from);
6126 /* Set the new upper bound. */
6127 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6128 gfc_rank_cst[dim], to);
6130 /* Multiply the stride by the section stride to get the
6132 stride = fold_build2_loc (input_location, MULT_EXPR,
6133 gfc_array_index_type,
6134 stride, info->stride[n]);
6136 if (se->direct_byref
6138 && info->ref->u.ar.type != AR_FULL)
6140 base = fold_build2_loc (input_location, MINUS_EXPR,
6141 TREE_TYPE (base), base, stride);
6143 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6145 tmp = gfc_conv_array_lbound (desc, n);
6146 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6147 TREE_TYPE (base), tmp, loop.from[dim]);
6148 tmp = fold_build2_loc (input_location, MULT_EXPR,
6149 TREE_TYPE (base), tmp,
6150 gfc_conv_array_stride (desc, n));
6151 base = fold_build2_loc (input_location, PLUS_EXPR,
6152 TREE_TYPE (base), tmp, base);
6155 /* Store the new stride. */
6156 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6157 gfc_rank_cst[dim], stride);
6160 for (n = loop.dimen; n < loop.dimen + codim; n++)
6162 from = loop.from[n];
6164 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6165 gfc_rank_cst[n], from);
6166 if (n < loop.dimen + codim - 1)
6167 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6168 gfc_rank_cst[n], to);
6171 if (se->data_not_needed)
6172 gfc_conv_descriptor_data_set (&loop.pre, parm,
6173 gfc_index_zero_node);
6175 /* Point the data pointer at the 1st element in the section. */
6176 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6177 subref_array_target, expr);
6179 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6180 && !se->data_not_needed)
6182 /* Set the offset. */
6183 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6187 /* Only the callee knows what the correct offset it, so just set
6189 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6194 if (!se->direct_byref || se->byref_noassign)
6196 /* Get a pointer to the new descriptor. */
6197 if (se->want_pointer)
6198 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6203 gfc_add_block_to_block (&se->pre, &loop.pre);
6204 gfc_add_block_to_block (&se->post, &loop.post);
6206 /* Cleanup the scalarizer. */
6207 gfc_cleanup_loop (&loop);
6210 /* Helper function for gfc_conv_array_parameter if array size needs to be
6214 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6217 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6218 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6219 else if (expr->rank > 1)
6220 *size = build_call_expr_loc (input_location,
6221 gfor_fndecl_size0, 1,
6222 gfc_build_addr_expr (NULL, desc));
6225 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6226 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6228 *size = fold_build2_loc (input_location, MINUS_EXPR,
6229 gfc_array_index_type, ubound, lbound);
6230 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6231 *size, gfc_index_one_node);
6232 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6233 *size, gfc_index_zero_node);
6235 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6236 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6237 *size, fold_convert (gfc_array_index_type, elem));
6240 /* Convert an array for passing as an actual parameter. */
6241 /* TODO: Optimize passing g77 arrays. */
6244 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6245 const gfc_symbol *fsym, const char *proc_name,
6250 tree tmp = NULL_TREE;
6252 tree parent = DECL_CONTEXT (current_function_decl);
6253 bool full_array_var;
6254 bool this_array_result;
6257 bool array_constructor;
6258 bool good_allocatable;
6259 bool ultimate_ptr_comp;
6260 bool ultimate_alloc_comp;
6265 ultimate_ptr_comp = false;
6266 ultimate_alloc_comp = false;
6268 for (ref = expr->ref; ref; ref = ref->next)
6270 if (ref->next == NULL)
6273 if (ref->type == REF_COMPONENT)
6275 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6276 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6280 full_array_var = false;
6283 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6284 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6286 sym = full_array_var ? expr->symtree->n.sym : NULL;
6288 /* The symbol should have an array specification. */
6289 gcc_assert (!sym || sym->as || ref->u.ar.as);
6291 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6293 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6294 expr->ts.u.cl->backend_decl = tmp;
6295 se->string_length = tmp;
6298 /* Is this the result of the enclosing procedure? */
6299 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6300 if (this_array_result
6301 && (sym->backend_decl != current_function_decl)
6302 && (sym->backend_decl != parent))
6303 this_array_result = false;
6305 /* Passing address of the array if it is not pointer or assumed-shape. */
6306 if (full_array_var && g77 && !this_array_result)
6308 tmp = gfc_get_symbol_decl (sym);
6310 if (sym->ts.type == BT_CHARACTER)
6311 se->string_length = sym->ts.u.cl->backend_decl;
6313 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6315 gfc_conv_expr_descriptor (se, expr, ss);
6316 se->expr = gfc_conv_array_data (se->expr);
6320 if (!sym->attr.pointer
6322 && sym->as->type != AS_ASSUMED_SHAPE
6323 && !sym->attr.allocatable)
6325 /* Some variables are declared directly, others are declared as
6326 pointers and allocated on the heap. */
6327 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6330 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6332 array_parameter_size (tmp, expr, size);
6336 if (sym->attr.allocatable)
6338 if (sym->attr.dummy || sym->attr.result)
6340 gfc_conv_expr_descriptor (se, expr, ss);
6344 array_parameter_size (tmp, expr, size);
6345 se->expr = gfc_conv_array_data (tmp);
6350 /* A convenient reduction in scope. */
6351 contiguous = g77 && !this_array_result && contiguous;
6353 /* There is no need to pack and unpack the array, if it is contiguous
6354 and not a deferred- or assumed-shape array, or if it is simply
6356 no_pack = ((sym && sym->as
6357 && !sym->attr.pointer
6358 && sym->as->type != AS_DEFERRED
6359 && sym->as->type != AS_ASSUMED_SHAPE)
6361 (ref && ref->u.ar.as
6362 && ref->u.ar.as->type != AS_DEFERRED
6363 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6365 gfc_is_simply_contiguous (expr, false));
6367 no_pack = contiguous && no_pack;
6369 /* Array constructors are always contiguous and do not need packing. */
6370 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6372 /* Same is true of contiguous sections from allocatable variables. */
6373 good_allocatable = contiguous
6375 && expr->symtree->n.sym->attr.allocatable;
6377 /* Or ultimate allocatable components. */
6378 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6380 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6382 gfc_conv_expr_descriptor (se, expr, ss);
6383 if (expr->ts.type == BT_CHARACTER)
6384 se->string_length = expr->ts.u.cl->backend_decl;
6386 array_parameter_size (se->expr, expr, size);
6387 se->expr = gfc_conv_array_data (se->expr);
6391 if (this_array_result)
6393 /* Result of the enclosing function. */
6394 gfc_conv_expr_descriptor (se, expr, ss);
6396 array_parameter_size (se->expr, expr, size);
6397 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6399 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6400 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6401 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6408 /* Every other type of array. */
6409 se->want_pointer = 1;
6410 gfc_conv_expr_descriptor (se, expr, ss);
6412 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6417 /* Deallocate the allocatable components of structures that are
6419 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6420 && expr->ts.u.derived->attr.alloc_comp
6421 && expr->expr_type != EXPR_VARIABLE)
6423 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6424 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6426 /* The components shall be deallocated before their containing entity. */
6427 gfc_prepend_expr_to_block (&se->post, tmp);
6430 if (g77 || (fsym && fsym->attr.contiguous
6431 && !gfc_is_simply_contiguous (expr, false)))
6433 tree origptr = NULL_TREE;
6437 /* For contiguous arrays, save the original value of the descriptor. */
6440 origptr = gfc_create_var (pvoid_type_node, "origptr");
6441 tmp = build_fold_indirect_ref_loc (input_location, desc);
6442 tmp = gfc_conv_array_data (tmp);
6443 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6444 TREE_TYPE (origptr), origptr,
6445 fold_convert (TREE_TYPE (origptr), tmp));
6446 gfc_add_expr_to_block (&se->pre, tmp);
6449 /* Repack the array. */
6450 if (gfc_option.warn_array_temp)
6453 gfc_warning ("Creating array temporary at %L for argument '%s'",
6454 &expr->where, fsym->name);
6456 gfc_warning ("Creating array temporary at %L", &expr->where);
6459 ptr = build_call_expr_loc (input_location,
6460 gfor_fndecl_in_pack, 1, desc);
6462 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6464 tmp = gfc_conv_expr_present (sym);
6465 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6466 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6467 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6470 ptr = gfc_evaluate_now (ptr, &se->pre);
6472 /* Use the packed data for the actual argument, except for contiguous arrays,
6473 where the descriptor's data component is set. */
6478 tmp = build_fold_indirect_ref_loc (input_location, desc);
6479 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6482 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6486 if (fsym && proc_name)
6487 asprintf (&msg, "An array temporary was created for argument "
6488 "'%s' of procedure '%s'", fsym->name, proc_name);
6490 asprintf (&msg, "An array temporary was created");
6492 tmp = build_fold_indirect_ref_loc (input_location,
6494 tmp = gfc_conv_array_data (tmp);
6495 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6496 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6498 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6499 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6501 gfc_conv_expr_present (sym), tmp);
6503 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6508 gfc_start_block (&block);
6510 /* Copy the data back. */
6511 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6513 tmp = build_call_expr_loc (input_location,
6514 gfor_fndecl_in_unpack, 2, desc, ptr);
6515 gfc_add_expr_to_block (&block, tmp);
6518 /* Free the temporary. */
6519 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6520 gfc_add_expr_to_block (&block, tmp);
6522 stmt = gfc_finish_block (&block);
6524 gfc_init_block (&block);
6525 /* Only if it was repacked. This code needs to be executed before the
6526 loop cleanup code. */
6527 tmp = build_fold_indirect_ref_loc (input_location,
6529 tmp = gfc_conv_array_data (tmp);
6530 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6531 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6533 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6534 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6536 gfc_conv_expr_present (sym), tmp);
6538 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6540 gfc_add_expr_to_block (&block, tmp);
6541 gfc_add_block_to_block (&block, &se->post);
6543 gfc_init_block (&se->post);
6545 /* Reset the descriptor pointer. */
6548 tmp = build_fold_indirect_ref_loc (input_location, desc);
6549 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6552 gfc_add_block_to_block (&se->post, &block);
6557 /* Generate code to deallocate an array, if it is allocated. */
6560 gfc_trans_dealloc_allocated (tree descriptor)
6566 gfc_start_block (&block);
6568 var = gfc_conv_descriptor_data_get (descriptor);
6571 /* Call array_deallocate with an int * present in the second argument.
6572 Although it is ignored here, it's presence ensures that arrays that
6573 are already deallocated are ignored. */
6574 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6575 gfc_add_expr_to_block (&block, tmp);
6577 /* Zero the data pointer. */
6578 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6579 var, build_int_cst (TREE_TYPE (var), 0));
6580 gfc_add_expr_to_block (&block, tmp);
6582 return gfc_finish_block (&block);
6586 /* This helper function calculates the size in words of a full array. */
6589 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6594 idx = gfc_rank_cst[rank - 1];
6595 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6596 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6597 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6599 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6600 tmp, gfc_index_one_node);
6601 tmp = gfc_evaluate_now (tmp, block);
6603 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6604 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6606 return gfc_evaluate_now (tmp, block);
6610 /* Allocate dest to the same size as src, and copy src -> dest.
6611 If no_malloc is set, only the copy is done. */
6614 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6624 /* If the source is null, set the destination to null. Then,
6625 allocate memory to the destination. */
6626 gfc_init_block (&block);
6630 tmp = null_pointer_node;
6631 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6632 gfc_add_expr_to_block (&block, tmp);
6633 null_data = gfc_finish_block (&block);
6635 gfc_init_block (&block);
6636 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6639 tmp = gfc_call_malloc (&block, type, size);
6640 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6641 dest, fold_convert (type, tmp));
6642 gfc_add_expr_to_block (&block, tmp);
6645 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6646 tmp = build_call_expr_loc (input_location, tmp, 3,
6651 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6652 null_data = gfc_finish_block (&block);
6654 gfc_init_block (&block);
6655 nelems = get_full_array_size (&block, src, rank);
6656 tmp = fold_convert (gfc_array_index_type,
6657 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6658 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6662 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6663 tmp = gfc_call_malloc (&block, tmp, size);
6664 gfc_conv_descriptor_data_set (&block, dest, tmp);
6667 /* We know the temporary and the value will be the same length,
6668 so can use memcpy. */
6669 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6670 tmp = build_call_expr_loc (input_location,
6671 tmp, 3, gfc_conv_descriptor_data_get (dest),
6672 gfc_conv_descriptor_data_get (src), size);
6675 gfc_add_expr_to_block (&block, tmp);
6676 tmp = gfc_finish_block (&block);
6678 /* Null the destination if the source is null; otherwise do
6679 the allocate and copy. */
6683 null_cond = gfc_conv_descriptor_data_get (src);
6685 null_cond = convert (pvoid_type_node, null_cond);
6686 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6687 null_cond, null_pointer_node);
6688 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6692 /* Allocate dest to the same size as src, and copy data src -> dest. */
6695 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6697 return duplicate_allocatable (dest, src, type, rank, false);
6701 /* Copy data src -> dest. */
6704 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6706 return duplicate_allocatable (dest, src, type, rank, true);
6710 /* Recursively traverse an object of derived type, generating code to
6711 deallocate, nullify or copy allocatable components. This is the work horse
6712 function for the functions named in this enum. */
6714 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6715 COPY_ONLY_ALLOC_COMP};
6718 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6719 tree dest, int rank, int purpose)
6723 stmtblock_t fnblock;
6724 stmtblock_t loopbody;
6735 tree null_cond = NULL_TREE;
6737 gfc_init_block (&fnblock);
6739 decl_type = TREE_TYPE (decl);
6741 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6742 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6744 decl = build_fold_indirect_ref_loc (input_location,
6747 /* Just in case in gets dereferenced. */
6748 decl_type = TREE_TYPE (decl);
6750 /* If this an array of derived types with allocatable components
6751 build a loop and recursively call this function. */
6752 if (TREE_CODE (decl_type) == ARRAY_TYPE
6753 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6755 tmp = gfc_conv_array_data (decl);
6756 var = build_fold_indirect_ref_loc (input_location,
6759 /* Get the number of elements - 1 and set the counter. */
6760 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6762 /* Use the descriptor for an allocatable array. Since this
6763 is a full array reference, we only need the descriptor
6764 information from dimension = rank. */
6765 tmp = get_full_array_size (&fnblock, decl, rank);
6766 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6767 gfc_array_index_type, tmp,
6768 gfc_index_one_node);
6770 null_cond = gfc_conv_descriptor_data_get (decl);
6771 null_cond = fold_build2_loc (input_location, NE_EXPR,
6772 boolean_type_node, null_cond,
6773 build_int_cst (TREE_TYPE (null_cond), 0));
6777 /* Otherwise use the TYPE_DOMAIN information. */
6778 tmp = array_type_nelts (decl_type);
6779 tmp = fold_convert (gfc_array_index_type, tmp);
6782 /* Remember that this is, in fact, the no. of elements - 1. */
6783 nelems = gfc_evaluate_now (tmp, &fnblock);
6784 index = gfc_create_var (gfc_array_index_type, "S");
6786 /* Build the body of the loop. */
6787 gfc_init_block (&loopbody);
6789 vref = gfc_build_array_ref (var, index, NULL);
6791 if (purpose == COPY_ALLOC_COMP)
6793 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6795 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6796 gfc_add_expr_to_block (&fnblock, tmp);
6798 tmp = build_fold_indirect_ref_loc (input_location,
6799 gfc_conv_array_data (dest));
6800 dref = gfc_build_array_ref (tmp, index, NULL);
6801 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6803 else if (purpose == COPY_ONLY_ALLOC_COMP)
6805 tmp = build_fold_indirect_ref_loc (input_location,
6806 gfc_conv_array_data (dest));
6807 dref = gfc_build_array_ref (tmp, index, NULL);
6808 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6812 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6814 gfc_add_expr_to_block (&loopbody, tmp);
6816 /* Build the loop and return. */
6817 gfc_init_loopinfo (&loop);
6819 loop.from[0] = gfc_index_zero_node;
6820 loop.loopvar[0] = index;
6821 loop.to[0] = nelems;
6822 gfc_trans_scalarizing_loops (&loop, &loopbody);
6823 gfc_add_block_to_block (&fnblock, &loop.pre);
6825 tmp = gfc_finish_block (&fnblock);
6826 if (null_cond != NULL_TREE)
6827 tmp = build3_v (COND_EXPR, null_cond, tmp,
6828 build_empty_stmt (input_location));
6833 /* Otherwise, act on the components or recursively call self to
6834 act on a chain of components. */
6835 for (c = der_type->components; c; c = c->next)
6837 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6838 || c->ts.type == BT_CLASS)
6839 && c->ts.u.derived->attr.alloc_comp;
6840 cdecl = c->backend_decl;
6841 ctype = TREE_TYPE (cdecl);
6845 case DEALLOCATE_ALLOC_COMP:
6846 if (cmp_has_alloc_comps && !c->attr.pointer)
6848 /* Do not deallocate the components of ultimate pointer
6850 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6851 decl, cdecl, NULL_TREE);
6852 rank = c->as ? c->as->rank : 0;
6853 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6855 gfc_add_expr_to_block (&fnblock, tmp);
6858 if (c->attr.allocatable
6859 && (c->attr.dimension || c->attr.codimension))
6861 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6862 decl, cdecl, NULL_TREE);
6863 tmp = gfc_trans_dealloc_allocated (comp);
6864 gfc_add_expr_to_block (&fnblock, tmp);
6866 else if (c->attr.allocatable)
6868 /* Allocatable scalar components. */
6869 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6870 decl, cdecl, NULL_TREE);
6872 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6874 gfc_add_expr_to_block (&fnblock, tmp);
6876 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6877 void_type_node, comp,
6878 build_int_cst (TREE_TYPE (comp), 0));
6879 gfc_add_expr_to_block (&fnblock, tmp);
6881 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6883 /* Allocatable scalar CLASS components. */
6884 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6885 decl, cdecl, NULL_TREE);
6887 /* Add reference to '_data' component. */
6888 tmp = CLASS_DATA (c)->backend_decl;
6889 comp = fold_build3_loc (input_location, COMPONENT_REF,
6890 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6892 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6893 CLASS_DATA (c)->ts);
6894 gfc_add_expr_to_block (&fnblock, tmp);
6896 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6897 void_type_node, comp,
6898 build_int_cst (TREE_TYPE (comp), 0));
6899 gfc_add_expr_to_block (&fnblock, tmp);
6903 case NULLIFY_ALLOC_COMP:
6904 if (c->attr.pointer)
6906 else if (c->attr.allocatable
6907 && (c->attr.dimension|| c->attr.codimension))
6909 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6910 decl, cdecl, NULL_TREE);
6911 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6913 else if (c->attr.allocatable)
6915 /* Allocatable scalar components. */
6916 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6917 decl, cdecl, NULL_TREE);
6918 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6919 void_type_node, comp,
6920 build_int_cst (TREE_TYPE (comp), 0));
6921 gfc_add_expr_to_block (&fnblock, tmp);
6923 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6925 /* Allocatable scalar CLASS components. */
6926 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6927 decl, cdecl, NULL_TREE);
6928 /* Add reference to '_data' component. */
6929 tmp = CLASS_DATA (c)->backend_decl;
6930 comp = fold_build3_loc (input_location, COMPONENT_REF,
6931 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6932 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6933 void_type_node, comp,
6934 build_int_cst (TREE_TYPE (comp), 0));
6935 gfc_add_expr_to_block (&fnblock, tmp);
6937 else if (cmp_has_alloc_comps)
6939 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6940 decl, cdecl, NULL_TREE);
6941 rank = c->as ? c->as->rank : 0;
6942 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6944 gfc_add_expr_to_block (&fnblock, tmp);
6948 case COPY_ALLOC_COMP:
6949 if (c->attr.pointer)
6952 /* We need source and destination components. */
6953 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6955 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6957 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6959 if (c->attr.allocatable && !cmp_has_alloc_comps)
6961 rank = c->as ? c->as->rank : 0;
6962 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6963 gfc_add_expr_to_block (&fnblock, tmp);
6966 if (cmp_has_alloc_comps)
6968 rank = c->as ? c->as->rank : 0;
6969 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6970 gfc_add_modify (&fnblock, dcmp, tmp);
6971 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6973 gfc_add_expr_to_block (&fnblock, tmp);
6983 return gfc_finish_block (&fnblock);
6986 /* Recursively traverse an object of derived type, generating code to
6987 nullify allocatable components. */
6990 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6992 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6993 NULLIFY_ALLOC_COMP);
6997 /* Recursively traverse an object of derived type, generating code to
6998 deallocate allocatable components. */
7001 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7003 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7004 DEALLOCATE_ALLOC_COMP);
7008 /* Recursively traverse an object of derived type, generating code to
7009 copy it and its allocatable components. */
7012 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7014 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7018 /* Recursively traverse an object of derived type, generating code to
7019 copy only its allocatable components. */
7022 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7024 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7028 /* Returns the value of LBOUND for an expression. This could be broken out
7029 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7030 called by gfc_alloc_allocatable_for_assignment. */
7032 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7037 tree cond, cond1, cond3, cond4;
7041 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7043 tmp = gfc_rank_cst[dim];
7044 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7045 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7046 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7047 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7049 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7050 stride, gfc_index_zero_node);
7051 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7052 boolean_type_node, cond3, cond1);
7053 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7054 stride, gfc_index_zero_node);
7056 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7057 tmp, build_int_cst (gfc_array_index_type,
7060 cond = boolean_false_node;
7062 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7063 boolean_type_node, cond3, cond4);
7064 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7065 boolean_type_node, cond, cond1);
7067 return fold_build3_loc (input_location, COND_EXPR,
7068 gfc_array_index_type, cond,
7069 lbound, gfc_index_one_node);
7071 else if (expr->expr_type == EXPR_VARIABLE)
7073 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7074 for (ref = expr->ref; ref; ref = ref->next)
7076 if (ref->type == REF_COMPONENT
7077 && ref->u.c.component->as
7079 && ref->next->u.ar.type == AR_FULL)
7080 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7082 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7084 else if (expr->expr_type == EXPR_FUNCTION)
7086 /* A conversion function, so use the argument. */
7087 expr = expr->value.function.actual->expr;
7088 if (expr->expr_type != EXPR_VARIABLE)
7089 return gfc_index_one_node;
7090 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7091 return get_std_lbound (expr, desc, dim, assumed_size);
7094 return gfc_index_one_node;
7098 /* Returns true if an expression represents an lhs that can be reallocated
7102 gfc_is_reallocatable_lhs (gfc_expr *expr)
7109 /* An allocatable variable. */
7110 if (expr->symtree->n.sym->attr.allocatable
7112 && expr->ref->type == REF_ARRAY
7113 && expr->ref->u.ar.type == AR_FULL)
7116 /* All that can be left are allocatable components. */
7117 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7118 && expr->symtree->n.sym->ts.type != BT_CLASS)
7119 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7122 /* Find a component ref followed by an array reference. */
7123 for (ref = expr->ref; ref; ref = ref->next)
7125 && ref->type == REF_COMPONENT
7126 && ref->next->type == REF_ARRAY
7127 && !ref->next->next)
7133 /* Return true if valid reallocatable lhs. */
7134 if (ref->u.c.component->attr.allocatable
7135 && ref->next->u.ar.type == AR_FULL)
7142 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7146 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7150 stmtblock_t realloc_block;
7151 stmtblock_t alloc_block;
7174 gfc_array_spec * as;
7176 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7177 Find the lhs expression in the loop chain and set expr1 and
7178 expr2 accordingly. */
7179 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7182 /* Find the ss for the lhs. */
7184 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7185 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7187 if (lss == gfc_ss_terminator)
7192 /* Bail out if this is not a valid allocate on assignment. */
7193 if (!gfc_is_reallocatable_lhs (expr1)
7194 || (expr2 && !expr2->rank))
7197 /* Find the ss for the lhs. */
7199 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7200 if (lss->expr == expr1)
7203 if (lss == gfc_ss_terminator)
7206 /* Find an ss for the rhs. For operator expressions, we see the
7207 ss's for the operands. Any one of these will do. */
7209 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7210 if (rss->expr != expr1 && rss != loop->temp_ss)
7213 if (expr2 && rss == gfc_ss_terminator)
7216 gfc_start_block (&fblock);
7218 /* Since the lhs is allocatable, this must be a descriptor type.
7219 Get the data and array size. */
7220 desc = lss->data.info.descriptor;
7221 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7222 array1 = gfc_conv_descriptor_data_get (desc);
7224 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7225 deallocated if expr is an array of different shape or any of the
7226 corresponding length type parameter values of variable and expr
7227 differ." This assures F95 compatibility. */
7228 jump_label1 = gfc_build_label_decl (NULL_TREE);
7229 jump_label2 = gfc_build_label_decl (NULL_TREE);
7231 /* Allocate if data is NULL. */
7232 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7233 array1, build_int_cst (TREE_TYPE (array1), 0));
7234 tmp = build3_v (COND_EXPR, cond,
7235 build1_v (GOTO_EXPR, jump_label1),
7236 build_empty_stmt (input_location));
7237 gfc_add_expr_to_block (&fblock, tmp);
7239 /* Get arrayspec if expr is a full array. */
7240 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7241 && expr2->value.function.isym
7242 && expr2->value.function.isym->conversion)
7244 /* For conversion functions, take the arg. */
7245 gfc_expr *arg = expr2->value.function.actual->expr;
7246 as = gfc_get_full_arrayspec_from_expr (arg);
7249 as = gfc_get_full_arrayspec_from_expr (expr2);
7253 /* If the lhs shape is not the same as the rhs jump to setting the
7254 bounds and doing the reallocation....... */
7255 for (n = 0; n < expr1->rank; n++)
7257 /* Check the shape. */
7258 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7259 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7260 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7261 gfc_array_index_type,
7262 loop->to[n], loop->from[n]);
7263 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7264 gfc_array_index_type,
7266 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7267 gfc_array_index_type,
7269 cond = fold_build2_loc (input_location, NE_EXPR,
7271 tmp, gfc_index_zero_node);
7272 tmp = build3_v (COND_EXPR, cond,
7273 build1_v (GOTO_EXPR, jump_label1),
7274 build_empty_stmt (input_location));
7275 gfc_add_expr_to_block (&fblock, tmp);
7278 /* ....else jump past the (re)alloc code. */
7279 tmp = build1_v (GOTO_EXPR, jump_label2);
7280 gfc_add_expr_to_block (&fblock, tmp);
7282 /* Add the label to start automatic (re)allocation. */
7283 tmp = build1_v (LABEL_EXPR, jump_label1);
7284 gfc_add_expr_to_block (&fblock, tmp);
7286 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7288 /* Get the rhs size. Fix both sizes. */
7290 desc2 = rss->data.info.descriptor;
7293 size2 = gfc_index_one_node;
7294 for (n = 0; n < expr2->rank; n++)
7296 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7297 gfc_array_index_type,
7298 loop->to[n], loop->from[n]);
7299 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7300 gfc_array_index_type,
7301 tmp, gfc_index_one_node);
7302 size2 = fold_build2_loc (input_location, MULT_EXPR,
7303 gfc_array_index_type,
7307 size1 = gfc_evaluate_now (size1, &fblock);
7308 size2 = gfc_evaluate_now (size2, &fblock);
7310 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7312 neq_size = gfc_evaluate_now (cond, &fblock);
7315 /* Now modify the lhs descriptor and the associated scalarizer
7316 variables. F2003 7.4.1.3: "If variable is or becomes an
7317 unallocated allocatable variable, then it is allocated with each
7318 deferred type parameter equal to the corresponding type parameters
7319 of expr , with the shape of expr , and with each lower bound equal
7320 to the corresponding element of LBOUND(expr)."
7321 Reuse size1 to keep a dimension-by-dimension track of the
7322 stride of the new array. */
7323 size1 = gfc_index_one_node;
7324 offset = gfc_index_zero_node;
7326 for (n = 0; n < expr2->rank; n++)
7328 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7329 gfc_array_index_type,
7330 loop->to[n], loop->from[n]);
7331 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7332 gfc_array_index_type,
7333 tmp, gfc_index_one_node);
7335 lbound = gfc_index_one_node;
7340 lbd = get_std_lbound (expr2, desc2, n,
7341 as->type == AS_ASSUMED_SIZE);
7342 ubound = fold_build2_loc (input_location,
7344 gfc_array_index_type,
7346 ubound = fold_build2_loc (input_location,
7348 gfc_array_index_type,
7353 gfc_conv_descriptor_lbound_set (&fblock, desc,
7356 gfc_conv_descriptor_ubound_set (&fblock, desc,
7359 gfc_conv_descriptor_stride_set (&fblock, desc,
7362 lbound = gfc_conv_descriptor_lbound_get (desc,
7364 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7365 gfc_array_index_type,
7367 offset = fold_build2_loc (input_location, MINUS_EXPR,
7368 gfc_array_index_type,
7370 size1 = fold_build2_loc (input_location, MULT_EXPR,
7371 gfc_array_index_type,
7375 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7376 the array offset is saved and the info.offset is used for a
7377 running offset. Use the saved_offset instead. */
7378 tmp = gfc_conv_descriptor_offset (desc);
7379 gfc_add_modify (&fblock, tmp, offset);
7380 if (lss->data.info.saved_offset
7381 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7382 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7384 /* Now set the deltas for the lhs. */
7385 for (n = 0; n < expr1->rank; n++)
7387 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7388 dim = lss->data.info.dim[n];
7389 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7390 gfc_array_index_type, tmp,
7392 if (lss->data.info.delta[dim]
7393 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7394 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7397 /* Get the new lhs size in bytes. */
7398 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7400 tmp = expr2->ts.u.cl->backend_decl;
7401 gcc_assert (expr1->ts.u.cl->backend_decl);
7402 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7403 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7405 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7407 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7408 tmp = fold_build2_loc (input_location, MULT_EXPR,
7409 gfc_array_index_type, tmp,
7410 expr1->ts.u.cl->backend_decl);
7413 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7414 tmp = fold_convert (gfc_array_index_type, tmp);
7415 size2 = fold_build2_loc (input_location, MULT_EXPR,
7416 gfc_array_index_type,
7418 size2 = fold_convert (size_type_node, size2);
7419 size2 = gfc_evaluate_now (size2, &fblock);
7421 /* Realloc expression. Note that the scalarizer uses desc.data
7422 in the array reference - (*desc.data)[<element>]. */
7423 gfc_init_block (&realloc_block);
7424 tmp = build_call_expr_loc (input_location,
7425 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
7426 fold_convert (pvoid_type_node, array1),
7428 gfc_conv_descriptor_data_set (&realloc_block,
7430 realloc_expr = gfc_finish_block (&realloc_block);
7432 /* Only reallocate if sizes are different. */
7433 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7434 build_empty_stmt (input_location));
7438 /* Malloc expression. */
7439 gfc_init_block (&alloc_block);
7440 tmp = build_call_expr_loc (input_location,
7441 builtin_decl_explicit (BUILT_IN_MALLOC),
7443 gfc_conv_descriptor_data_set (&alloc_block,
7445 tmp = gfc_conv_descriptor_dtype (desc);
7446 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7447 alloc_expr = gfc_finish_block (&alloc_block);
7449 /* Malloc if not allocated; realloc otherwise. */
7450 tmp = build_int_cst (TREE_TYPE (array1), 0);
7451 cond = fold_build2_loc (input_location, EQ_EXPR,
7454 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7455 gfc_add_expr_to_block (&fblock, tmp);
7457 /* Make sure that the scalarizer data pointer is updated. */
7458 if (lss->data.info.data
7459 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7461 tmp = gfc_conv_descriptor_data_get (desc);
7462 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7465 /* Add the exit label. */
7466 tmp = build1_v (LABEL_EXPR, jump_label2);
7467 gfc_add_expr_to_block (&fblock, tmp);
7469 return gfc_finish_block (&fblock);
7473 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7474 Do likewise, recursively if necessary, with the allocatable components of
7478 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7484 stmtblock_t cleanup;
7487 bool sym_has_alloc_comp;
7489 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7490 || sym->ts.type == BT_CLASS)
7491 && sym->ts.u.derived->attr.alloc_comp;
7493 /* Make sure the frontend gets these right. */
7494 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7495 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7496 "allocatable attribute or derived type without allocatable "
7499 gfc_save_backend_locus (&loc);
7500 gfc_set_backend_locus (&sym->declared_at);
7501 gfc_init_block (&init);
7503 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7504 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7506 if (sym->ts.type == BT_CHARACTER
7507 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7509 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7510 gfc_trans_vla_type_sizes (sym, &init);
7513 /* Dummy, use associated and result variables don't need anything special. */
7514 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7516 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7517 gfc_restore_backend_locus (&loc);
7521 descriptor = sym->backend_decl;
7523 /* Although static, derived types with default initializers and
7524 allocatable components must not be nulled wholesale; instead they
7525 are treated component by component. */
7526 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7528 /* SAVEd variables are not freed on exit. */
7529 gfc_trans_static_array_pointer (sym);
7531 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7532 gfc_restore_backend_locus (&loc);
7536 /* Get the descriptor type. */
7537 type = TREE_TYPE (sym->backend_decl);
7539 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7542 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7544 if (sym->value == NULL
7545 || !gfc_has_default_initializer (sym->ts.u.derived))
7547 rank = sym->as ? sym->as->rank : 0;
7548 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7550 gfc_add_expr_to_block (&init, tmp);
7553 gfc_init_default_dt (sym, &init, false);
7556 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7558 /* If the backend_decl is not a descriptor, we must have a pointer
7560 descriptor = build_fold_indirect_ref_loc (input_location,
7562 type = TREE_TYPE (descriptor);
7565 /* NULLIFY the data pointer. */
7566 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7567 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7569 gfc_restore_backend_locus (&loc);
7570 gfc_init_block (&cleanup);
7572 /* Allocatable arrays need to be freed when they go out of scope.
7573 The allocatable components of pointers must not be touched. */
7574 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7575 && !sym->attr.pointer && !sym->attr.save)
7578 rank = sym->as ? sym->as->rank : 0;
7579 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7580 gfc_add_expr_to_block (&cleanup, tmp);
7583 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7584 && !sym->attr.save && !sym->attr.result)
7586 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7587 gfc_add_expr_to_block (&cleanup, tmp);
7590 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7591 gfc_finish_block (&cleanup));
7594 /************ Expression Walking Functions ******************/
7596 /* Walk a variable reference.
7598 Possible extension - multiple component subscripts.
7599 x(:,:) = foo%a(:)%b(:)
7601 forall (i=..., j=...)
7602 x(i,j) = foo%a(j)%b(i)
7604 This adds a fair amount of complexity because you need to deal with more
7605 than one ref. Maybe handle in a similar manner to vector subscripts.
7606 Maybe not worth the effort. */
7610 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7614 for (ref = expr->ref; ref; ref = ref->next)
7615 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7618 return gfc_walk_array_ref (ss, expr, ref);
7623 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
7629 for (; ref; ref = ref->next)
7631 if (ref->type == REF_SUBSTRING)
7633 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
7634 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
7637 /* We're only interested in array sections from now on. */
7638 if (ref->type != REF_ARRAY)
7646 for (n = ar->dimen - 1; n >= 0; n--)
7647 ss = gfc_get_scalar_ss (ss, ar->start[n]);
7651 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
7652 newss->data.info.ref = ref;
7654 /* Make sure array is the same as array(:,:), this way
7655 we don't need to special case all the time. */
7656 ar->dimen = ar->as->rank;
7657 for (n = 0; n < ar->dimen; n++)
7659 ar->dimen_type[n] = DIMEN_RANGE;
7661 gcc_assert (ar->start[n] == NULL);
7662 gcc_assert (ar->end[n] == NULL);
7663 gcc_assert (ar->stride[n] == NULL);
7669 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
7670 newss->data.info.ref = ref;
7672 /* We add SS chains for all the subscripts in the section. */
7673 for (n = 0; n < ar->dimen; n++)
7677 switch (ar->dimen_type[n])
7680 /* Add SS for elemental (scalar) subscripts. */
7681 gcc_assert (ar->start[n]);
7682 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
7683 indexss->loop_chain = gfc_ss_terminator;
7684 newss->data.info.subscript[n] = indexss;
7688 /* We don't add anything for sections, just remember this
7689 dimension for later. */
7690 newss->data.info.dim[newss->data.info.dimen] = n;
7691 newss->data.info.dimen++;
7695 /* Create a GFC_SS_VECTOR index in which we can store
7696 the vector's descriptor. */
7697 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
7699 indexss->loop_chain = gfc_ss_terminator;
7700 newss->data.info.subscript[n] = indexss;
7701 newss->data.info.dim[newss->data.info.dimen] = n;
7702 newss->data.info.dimen++;
7706 /* We should know what sort of section it is by now. */
7710 /* We should have at least one non-elemental dimension,
7711 unless we are creating a descriptor for a (scalar) coarray. */
7712 gcc_assert (newss->data.info.dimen > 0
7713 || newss->data.info.ref->u.ar.as->corank > 0);
7718 /* We should know what sort of section it is by now. */
7727 /* Walk an expression operator. If only one operand of a binary expression is
7728 scalar, we must also add the scalar term to the SS chain. */
7731 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7736 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7737 if (expr->value.op.op2 == NULL)
7740 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7742 /* All operands are scalar. Pass back and let the caller deal with it. */
7746 /* All operands require scalarization. */
7747 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7750 /* One of the operands needs scalarization, the other is scalar.
7751 Create a gfc_ss for the scalar expression. */
7754 /* First operand is scalar. We build the chain in reverse order, so
7755 add the scalar SS after the second operand. */
7757 while (head && head->next != ss)
7759 /* Check we haven't somehow broken the chain. */
7761 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
7763 else /* head2 == head */
7765 gcc_assert (head2 == head);
7766 /* Second operand is scalar. */
7767 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
7774 /* Reverse a SS chain. */
7777 gfc_reverse_ss (gfc_ss * ss)
7782 gcc_assert (ss != NULL);
7784 head = gfc_ss_terminator;
7785 while (ss != gfc_ss_terminator)
7788 /* Check we didn't somehow break the chain. */
7789 gcc_assert (next != NULL);
7799 /* Walk the arguments of an elemental function. */
7802 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7810 head = gfc_ss_terminator;
7813 for (; arg; arg = arg->next)
7818 newss = gfc_walk_subexpr (head, arg->expr);
7821 /* Scalar argument. */
7822 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
7823 newss = gfc_get_scalar_ss (head, arg->expr);
7833 while (tail->next != gfc_ss_terminator)
7840 /* If all the arguments are scalar we don't need the argument SS. */
7841 gfc_free_ss_chain (head);
7846 /* Add it onto the existing chain. */
7852 /* Walk a function call. Scalar functions are passed back, and taken out of
7853 scalarization loops. For elemental functions we walk their arguments.
7854 The result of functions returning arrays is stored in a temporary outside
7855 the loop, so that the function is only called once. Hence we do not need
7856 to walk their arguments. */
7859 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7861 gfc_intrinsic_sym *isym;
7863 gfc_component *comp = NULL;
7865 isym = expr->value.function.isym;
7867 /* Handle intrinsic functions separately. */
7869 return gfc_walk_intrinsic_function (ss, expr, isym);
7871 sym = expr->value.function.esym;
7873 sym = expr->symtree->n.sym;
7875 /* A function that returns arrays. */
7876 gfc_is_proc_ptr_comp (expr, &comp);
7877 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7878 || (comp && comp->attr.dimension))
7879 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
7881 /* Walk the parameters of an elemental function. For now we always pass
7883 if (sym->attr.elemental)
7884 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7887 /* Scalar functions are OK as these are evaluated outside the scalarization
7888 loop. Pass back and let the caller deal with it. */
7893 /* An array temporary is constructed for array constructors. */
7896 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7898 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
7902 /* Walk an expression. Add walked expressions to the head of the SS chain.
7903 A wholly scalar expression will not be added. */
7906 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7910 switch (expr->expr_type)
7913 head = gfc_walk_variable_expr (ss, expr);
7917 head = gfc_walk_op_expr (ss, expr);
7921 head = gfc_walk_function_expr (ss, expr);
7926 case EXPR_STRUCTURE:
7927 /* Pass back and let the caller deal with it. */
7931 head = gfc_walk_array_constructor (ss, expr);
7934 case EXPR_SUBSTRING:
7935 /* Pass back and let the caller deal with it. */
7939 internal_error ("bad expression type during walk (%d)",
7946 /* Entry point for expression walking.
7947 A return value equal to the passed chain means this is
7948 a scalar expression. It is up to the caller to take whatever action is
7949 necessary to translate these. */
7952 gfc_walk_expr (gfc_expr * expr)
7956 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7957 return gfc_reverse_ss (res);