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;
530 for (i = 0; i < info->dimen; i++)
537 /* Creates and initializes a temporary type gfc_ss struct. */
540 gfc_get_temp_ss (tree type, tree string_length, int dimen)
545 ss->next = gfc_ss_terminator;
546 ss->type = GFC_SS_TEMP;
547 ss->string_length = string_length;
548 ss->data.temp.dimen = dimen;
549 ss->data.temp.type = type;
555 /* Creates and initializes a scalar type gfc_ss struct. */
558 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
564 ss->type = GFC_SS_SCALAR;
571 /* Free all the SS associated with a loop. */
574 gfc_cleanup_loop (gfc_loopinfo * loop)
580 while (ss != gfc_ss_terminator)
582 gcc_assert (ss != NULL);
583 next = ss->loop_chain;
590 /* Associate a SS chain with a loop. */
593 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
597 if (head == gfc_ss_terminator)
601 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
603 if (ss->next == gfc_ss_terminator)
604 ss->loop_chain = loop->ss;
606 ss->loop_chain = ss->next;
608 gcc_assert (ss == gfc_ss_terminator);
613 /* Generate an initializer for a static pointer or allocatable array. */
616 gfc_trans_static_array_pointer (gfc_symbol * sym)
620 gcc_assert (TREE_STATIC (sym->backend_decl));
621 /* Just zero the data member. */
622 type = TREE_TYPE (sym->backend_decl);
623 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
627 /* If the bounds of SE's loop have not yet been set, see if they can be
628 determined from array spec AS, which is the array spec of a called
629 function. MAPPING maps the callee's dummy arguments to the values
630 that the caller is passing. Add any initialization and finalization
634 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
635 gfc_se * se, gfc_array_spec * as)
643 if (as && as->type == AS_EXPLICIT)
644 for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
646 dim = se->ss->data.info.dim[n];
647 gcc_assert (dim < as->rank);
648 gcc_assert (se->loop->dimen == as->rank);
649 if (se->loop->to[n] == NULL_TREE)
651 /* Evaluate the lower bound. */
652 gfc_init_se (&tmpse, NULL);
653 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
654 gfc_add_block_to_block (&se->pre, &tmpse.pre);
655 gfc_add_block_to_block (&se->post, &tmpse.post);
656 lower = fold_convert (gfc_array_index_type, tmpse.expr);
658 if (se->loop->codimen == 0
659 || n < se->loop->dimen + se->loop->codimen - 1)
661 /* ...and the upper bound. */
662 gfc_init_se (&tmpse, NULL);
663 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
664 gfc_add_block_to_block (&se->pre, &tmpse.pre);
665 gfc_add_block_to_block (&se->post, &tmpse.post);
666 upper = fold_convert (gfc_array_index_type, tmpse.expr);
668 /* Set the upper bound of the loop to UPPER - LOWER. */
669 tmp = fold_build2_loc (input_location, MINUS_EXPR,
670 gfc_array_index_type, upper, lower);
671 tmp = gfc_evaluate_now (tmp, &se->pre);
672 se->loop->to[n] = tmp;
679 /* Generate code to allocate an array temporary, or create a variable to
680 hold the data. If size is NULL, zero the descriptor so that the
681 callee will allocate the array. If DEALLOC is true, also generate code to
682 free the array afterwards.
684 If INITIAL is not NULL, it is packed using internal_pack and the result used
685 as data instead of allocating a fresh, unitialized area of memory.
687 Initialization code is added to PRE and finalization code to POST.
688 DYNAMIC is true if the caller may want to extend the array later
689 using realloc. This prevents us from putting the array on the stack. */
692 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
693 gfc_ss_info * info, tree size, tree nelem,
694 tree initial, bool dynamic, bool dealloc)
700 desc = info->descriptor;
701 info->offset = gfc_index_zero_node;
702 if (size == NULL_TREE || integer_zerop (size))
704 /* A callee allocated array. */
705 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
710 /* Allocate the temporary. */
711 onstack = !dynamic && initial == NULL_TREE
712 && (gfc_option.flag_stack_arrays
713 || gfc_can_put_var_on_stack (size));
717 /* Make a temporary variable to hold the data. */
718 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
719 nelem, gfc_index_one_node);
720 tmp = gfc_evaluate_now (tmp, pre);
721 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
723 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
725 tmp = gfc_create_var (tmp, "A");
726 /* If we're here only because of -fstack-arrays we have to
727 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
728 if (!gfc_can_put_var_on_stack (size))
729 gfc_add_expr_to_block (pre,
730 fold_build1_loc (input_location,
731 DECL_EXPR, TREE_TYPE (tmp),
733 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
734 gfc_conv_descriptor_data_set (pre, desc, tmp);
738 /* Allocate memory to hold the data or call internal_pack. */
739 if (initial == NULL_TREE)
741 tmp = gfc_call_malloc (pre, NULL, size);
742 tmp = gfc_evaluate_now (tmp, pre);
749 stmtblock_t do_copying;
751 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
752 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
753 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
754 tmp = gfc_get_element_type (tmp);
755 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
756 packed = gfc_create_var (build_pointer_type (tmp), "data");
758 tmp = build_call_expr_loc (input_location,
759 gfor_fndecl_in_pack, 1, initial);
760 tmp = fold_convert (TREE_TYPE (packed), tmp);
761 gfc_add_modify (pre, packed, tmp);
763 tmp = build_fold_indirect_ref_loc (input_location,
765 source_data = gfc_conv_descriptor_data_get (tmp);
767 /* internal_pack may return source->data without any allocation
768 or copying if it is already packed. If that's the case, we
769 need to allocate and copy manually. */
771 gfc_start_block (&do_copying);
772 tmp = gfc_call_malloc (&do_copying, NULL, size);
773 tmp = fold_convert (TREE_TYPE (packed), tmp);
774 gfc_add_modify (&do_copying, packed, tmp);
775 tmp = gfc_build_memcpy_call (packed, source_data, size);
776 gfc_add_expr_to_block (&do_copying, tmp);
778 was_packed = fold_build2_loc (input_location, EQ_EXPR,
779 boolean_type_node, packed,
781 tmp = gfc_finish_block (&do_copying);
782 tmp = build3_v (COND_EXPR, was_packed, tmp,
783 build_empty_stmt (input_location));
784 gfc_add_expr_to_block (pre, tmp);
786 tmp = fold_convert (pvoid_type_node, packed);
789 gfc_conv_descriptor_data_set (pre, desc, tmp);
792 info->data = gfc_conv_descriptor_data_get (desc);
794 /* The offset is zero because we create temporaries with a zero
796 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
798 if (dealloc && !onstack)
800 /* Free the temporary. */
801 tmp = gfc_conv_descriptor_data_get (desc);
802 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
803 gfc_add_expr_to_block (post, tmp);
808 /* Get the array reference dimension corresponding to the given loop dimension.
809 It is different from the true array dimension given by the dim array in
810 the case of a partial array reference
811 It is different from the loop dimension in the case of a transposed array.
815 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
817 int n, array_dim, array_ref_dim;
820 array_dim = info->dim[loop_dim];
822 for (n = 0; n < info->dimen; n++)
823 if (n != loop_dim && info->dim[n] < array_dim)
826 return array_ref_dim;
830 /* Generate code to create and initialize the descriptor for a temporary
831 array. This is used for both temporaries needed by the scalarizer, and
832 functions returning arrays. Adjusts the loop variables to be
833 zero-based, and calculates the loop bounds for callee allocated arrays.
834 Allocate the array unless it's callee allocated (we have a callee
835 allocated array if 'callee_alloc' is true, or if loop->to[n] is
836 NULL_TREE for any n). Also fills in the descriptor, data and offset
837 fields of info if known. Returns the size of the array, or NULL for a
838 callee allocated array.
840 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
841 gfc_trans_allocate_array_storage.
845 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
846 gfc_loopinfo * loop, gfc_ss_info * info,
847 tree eltype, tree initial, bool dynamic,
848 bool dealloc, bool callee_alloc, locus * where)
850 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
860 memset (from, 0, sizeof (from));
861 memset (to, 0, sizeof (to));
863 gcc_assert (info->dimen > 0);
864 gcc_assert (loop->dimen == info->dimen);
866 if (gfc_option.warn_array_temp && where)
867 gfc_warning ("Creating array temporary at %L", where);
869 /* Set the lower bound to zero. */
870 for (n = 0; n < loop->dimen; n++)
874 /* Callee allocated arrays may not have a known bound yet. */
876 loop->to[n] = gfc_evaluate_now (
877 fold_build2_loc (input_location, MINUS_EXPR,
878 gfc_array_index_type,
879 loop->to[n], loop->from[n]),
881 loop->from[n] = gfc_index_zero_node;
883 /* We are constructing the temporary's descriptor based on the loop
884 dimensions. As the dimensions may be accessed in arbitrary order
885 (think of transpose) the size taken from the n'th loop may not map
886 to the n'th dimension of the array. We need to reconstruct loop infos
887 in the right order before using it to set the descriptor
889 tmp_dim = get_array_ref_dim (info, n);
890 from[tmp_dim] = loop->from[n];
891 to[tmp_dim] = loop->to[n];
893 info->delta[dim] = gfc_index_zero_node;
894 info->start[dim] = gfc_index_zero_node;
895 info->end[dim] = gfc_index_zero_node;
896 info->stride[dim] = gfc_index_one_node;
899 /* Initialize the descriptor. */
901 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
902 GFC_ARRAY_UNKNOWN, true);
903 desc = gfc_create_var (type, "atmp");
904 GFC_DECL_PACKED_ARRAY (desc) = 1;
906 info->descriptor = desc;
907 size = gfc_index_one_node;
909 /* Fill in the array dtype. */
910 tmp = gfc_conv_descriptor_dtype (desc);
911 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
914 Fill in the bounds and stride. This is a packed array, so:
917 for (n = 0; n < rank; n++)
920 delta = ubound[n] + 1 - lbound[n];
923 size = size * sizeof(element);
928 /* If there is at least one null loop->to[n], it is a callee allocated
930 for (n = 0; n < loop->dimen; n++)
931 if (loop->to[n] == NULL_TREE)
937 for (n = 0; n < loop->dimen; n++)
941 if (size == NULL_TREE)
943 /* For a callee allocated array express the loop bounds in terms
944 of the descriptor fields. */
945 tmp = fold_build2_loc (input_location,
946 MINUS_EXPR, gfc_array_index_type,
947 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
948 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
953 /* Store the stride and bound components in the descriptor. */
954 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
956 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
957 gfc_index_zero_node);
959 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
962 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
963 to[n], gfc_index_one_node);
965 /* Check whether the size for this dimension is negative. */
966 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
967 gfc_index_zero_node);
968 cond = gfc_evaluate_now (cond, pre);
973 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
974 boolean_type_node, or_expr, cond);
976 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
978 size = gfc_evaluate_now (size, pre);
980 for (n = info->dimen; n < info->dimen + info->codimen; n++)
982 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
983 gfc_index_zero_node);
984 if (n < info->dimen + info->codimen - 1)
985 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
988 /* Get the size of the array. */
990 if (size && !callee_alloc)
992 /* If or_expr is true, then the extent in at least one
993 dimension is zero and the size is set to zero. */
994 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
995 or_expr, gfc_index_zero_node, size);
998 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1000 fold_convert (gfc_array_index_type,
1001 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
1009 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1012 if (info->dimen > loop->temp_dim)
1013 loop->temp_dim = info->dimen;
1019 /* Return the number of iterations in a loop that starts at START,
1020 ends at END, and has step STEP. */
1023 gfc_get_iteration_count (tree start, tree end, tree step)
1028 type = TREE_TYPE (step);
1029 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1030 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1031 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1032 build_int_cst (type, 1));
1033 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1034 build_int_cst (type, 0));
1035 return fold_convert (gfc_array_index_type, tmp);
1039 /* Extend the data in array DESC by EXTRA elements. */
1042 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1049 if (integer_zerop (extra))
1052 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1054 /* Add EXTRA to the upper bound. */
1055 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1057 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1059 /* Get the value of the current data pointer. */
1060 arg0 = gfc_conv_descriptor_data_get (desc);
1062 /* Calculate the new array size. */
1063 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1064 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1065 ubound, gfc_index_one_node);
1066 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1067 fold_convert (size_type_node, tmp),
1068 fold_convert (size_type_node, size));
1070 /* Call the realloc() function. */
1071 tmp = gfc_call_realloc (pblock, arg0, arg1);
1072 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1076 /* Return true if the bounds of iterator I can only be determined
1080 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1082 return (i->start->expr_type != EXPR_CONSTANT
1083 || i->end->expr_type != EXPR_CONSTANT
1084 || i->step->expr_type != EXPR_CONSTANT);
1088 /* Split the size of constructor element EXPR into the sum of two terms,
1089 one of which can be determined at compile time and one of which must
1090 be calculated at run time. Set *SIZE to the former and return true
1091 if the latter might be nonzero. */
1094 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1096 if (expr->expr_type == EXPR_ARRAY)
1097 return gfc_get_array_constructor_size (size, expr->value.constructor);
1098 else if (expr->rank > 0)
1100 /* Calculate everything at run time. */
1101 mpz_set_ui (*size, 0);
1106 /* A single element. */
1107 mpz_set_ui (*size, 1);
1113 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1114 of array constructor C. */
1117 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1125 mpz_set_ui (*size, 0);
1130 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1133 if (i && gfc_iterator_has_dynamic_bounds (i))
1137 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1140 /* Multiply the static part of the element size by the
1141 number of iterations. */
1142 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1143 mpz_fdiv_q (val, val, i->step->value.integer);
1144 mpz_add_ui (val, val, 1);
1145 if (mpz_sgn (val) > 0)
1146 mpz_mul (len, len, val);
1148 mpz_set_ui (len, 0);
1150 mpz_add (*size, *size, len);
1159 /* Make sure offset is a variable. */
1162 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1165 /* We should have already created the offset variable. We cannot
1166 create it here because we may be in an inner scope. */
1167 gcc_assert (*offsetvar != NULL_TREE);
1168 gfc_add_modify (pblock, *offsetvar, *poffset);
1169 *poffset = *offsetvar;
1170 TREE_USED (*offsetvar) = 1;
1174 /* Variables needed for bounds-checking. */
1175 static bool first_len;
1176 static tree first_len_val;
1177 static bool typespec_chararray_ctor;
1180 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1181 tree offset, gfc_se * se, gfc_expr * expr)
1185 gfc_conv_expr (se, expr);
1187 /* Store the value. */
1188 tmp = build_fold_indirect_ref_loc (input_location,
1189 gfc_conv_descriptor_data_get (desc));
1190 tmp = gfc_build_array_ref (tmp, offset, NULL);
1192 if (expr->ts.type == BT_CHARACTER)
1194 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1197 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1198 esize = fold_convert (gfc_charlen_type_node, esize);
1199 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1200 gfc_charlen_type_node, esize,
1201 build_int_cst (gfc_charlen_type_node,
1202 gfc_character_kinds[i].bit_size / 8));
1204 gfc_conv_string_parameter (se);
1205 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1207 /* The temporary is an array of pointers. */
1208 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1209 gfc_add_modify (&se->pre, tmp, se->expr);
1213 /* The temporary is an array of string values. */
1214 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1215 /* We know the temporary and the value will be the same length,
1216 so can use memcpy. */
1217 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1218 se->string_length, se->expr, expr->ts.kind);
1220 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1224 gfc_add_modify (&se->pre, first_len_val,
1230 /* Verify that all constructor elements are of the same
1232 tree cond = fold_build2_loc (input_location, NE_EXPR,
1233 boolean_type_node, first_len_val,
1235 gfc_trans_runtime_check
1236 (true, false, cond, &se->pre, &expr->where,
1237 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1238 fold_convert (long_integer_type_node, first_len_val),
1239 fold_convert (long_integer_type_node, se->string_length));
1245 /* TODO: Should the frontend already have done this conversion? */
1246 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1247 gfc_add_modify (&se->pre, tmp, se->expr);
1250 gfc_add_block_to_block (pblock, &se->pre);
1251 gfc_add_block_to_block (pblock, &se->post);
1255 /* Add the contents of an array to the constructor. DYNAMIC is as for
1256 gfc_trans_array_constructor_value. */
1259 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1260 tree type ATTRIBUTE_UNUSED,
1261 tree desc, gfc_expr * expr,
1262 tree * poffset, tree * offsetvar,
1273 /* We need this to be a variable so we can increment it. */
1274 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1276 gfc_init_se (&se, NULL);
1278 /* Walk the array expression. */
1279 ss = gfc_walk_expr (expr);
1280 gcc_assert (ss != gfc_ss_terminator);
1282 /* Initialize the scalarizer. */
1283 gfc_init_loopinfo (&loop);
1284 gfc_add_ss_to_loop (&loop, ss);
1286 /* Initialize the loop. */
1287 gfc_conv_ss_startstride (&loop);
1288 gfc_conv_loop_setup (&loop, &expr->where);
1290 /* Make sure the constructed array has room for the new data. */
1293 /* Set SIZE to the total number of elements in the subarray. */
1294 size = gfc_index_one_node;
1295 for (n = 0; n < loop.dimen; n++)
1297 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1298 gfc_index_one_node);
1299 size = fold_build2_loc (input_location, MULT_EXPR,
1300 gfc_array_index_type, size, tmp);
1303 /* Grow the constructed array by SIZE elements. */
1304 gfc_grow_array (&loop.pre, desc, size);
1307 /* Make the loop body. */
1308 gfc_mark_ss_chain_used (ss, 1);
1309 gfc_start_scalarized_body (&loop, &body);
1310 gfc_copy_loopinfo_to_se (&se, &loop);
1313 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1314 gcc_assert (se.ss == gfc_ss_terminator);
1316 /* Increment the offset. */
1317 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1318 *poffset, gfc_index_one_node);
1319 gfc_add_modify (&body, *poffset, tmp);
1321 /* Finish the loop. */
1322 gfc_trans_scalarizing_loops (&loop, &body);
1323 gfc_add_block_to_block (&loop.pre, &loop.post);
1324 tmp = gfc_finish_block (&loop.pre);
1325 gfc_add_expr_to_block (pblock, tmp);
1327 gfc_cleanup_loop (&loop);
1331 /* Assign the values to the elements of an array constructor. DYNAMIC
1332 is true if descriptor DESC only contains enough data for the static
1333 size calculated by gfc_get_array_constructor_size. When true, memory
1334 for the dynamic parts must be allocated using realloc. */
1337 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1338 tree desc, gfc_constructor_base base,
1339 tree * poffset, tree * offsetvar,
1348 tree shadow_loopvar = NULL_TREE;
1349 gfc_saved_var saved_loopvar;
1352 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1354 /* If this is an iterator or an array, the offset must be a variable. */
1355 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1356 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1358 /* Shadowing the iterator avoids changing its value and saves us from
1359 keeping track of it. Further, it makes sure that there's always a
1360 backend-decl for the symbol, even if there wasn't one before,
1361 e.g. in the case of an iterator that appears in a specification
1362 expression in an interface mapping. */
1365 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1366 tree type = gfc_typenode_for_spec (&sym->ts);
1368 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1369 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1372 gfc_start_block (&body);
1374 if (c->expr->expr_type == EXPR_ARRAY)
1376 /* Array constructors can be nested. */
1377 gfc_trans_array_constructor_value (&body, type, desc,
1378 c->expr->value.constructor,
1379 poffset, offsetvar, dynamic);
1381 else if (c->expr->rank > 0)
1383 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1384 poffset, offsetvar, dynamic);
1388 /* This code really upsets the gimplifier so don't bother for now. */
1395 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1397 p = gfc_constructor_next (p);
1402 /* Scalar values. */
1403 gfc_init_se (&se, NULL);
1404 gfc_trans_array_ctor_element (&body, desc, *poffset,
1407 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1408 gfc_array_index_type,
1409 *poffset, gfc_index_one_node);
1413 /* Collect multiple scalar constants into a constructor. */
1414 VEC(constructor_elt,gc) *v = NULL;
1418 HOST_WIDE_INT idx = 0;
1421 /* Count the number of consecutive scalar constants. */
1422 while (p && !(p->iterator
1423 || p->expr->expr_type != EXPR_CONSTANT))
1425 gfc_init_se (&se, NULL);
1426 gfc_conv_constant (&se, p->expr);
1428 if (c->expr->ts.type != BT_CHARACTER)
1429 se.expr = fold_convert (type, se.expr);
1430 /* For constant character array constructors we build
1431 an array of pointers. */
1432 else if (POINTER_TYPE_P (type))
1433 se.expr = gfc_build_addr_expr
1434 (gfc_get_pchar_type (p->expr->ts.kind),
1437 CONSTRUCTOR_APPEND_ELT (v,
1438 build_int_cst (gfc_array_index_type,
1442 p = gfc_constructor_next (p);
1445 bound = size_int (n - 1);
1446 /* Create an array type to hold them. */
1447 tmptype = build_range_type (gfc_array_index_type,
1448 gfc_index_zero_node, bound);
1449 tmptype = build_array_type (type, tmptype);
1451 init = build_constructor (tmptype, v);
1452 TREE_CONSTANT (init) = 1;
1453 TREE_STATIC (init) = 1;
1454 /* Create a static variable to hold the data. */
1455 tmp = gfc_create_var (tmptype, "data");
1456 TREE_STATIC (tmp) = 1;
1457 TREE_CONSTANT (tmp) = 1;
1458 TREE_READONLY (tmp) = 1;
1459 DECL_INITIAL (tmp) = init;
1462 /* Use BUILTIN_MEMCPY to assign the values. */
1463 tmp = gfc_conv_descriptor_data_get (desc);
1464 tmp = build_fold_indirect_ref_loc (input_location,
1466 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1467 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1468 init = gfc_build_addr_expr (NULL_TREE, init);
1470 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1471 bound = build_int_cst (size_type_node, n * size);
1472 tmp = build_call_expr_loc (input_location,
1473 built_in_decls[BUILT_IN_MEMCPY], 3,
1475 gfc_add_expr_to_block (&body, tmp);
1477 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1478 gfc_array_index_type, *poffset,
1479 build_int_cst (gfc_array_index_type, n));
1481 if (!INTEGER_CST_P (*poffset))
1483 gfc_add_modify (&body, *offsetvar, *poffset);
1484 *poffset = *offsetvar;
1488 /* The frontend should already have done any expansions
1492 /* Pass the code as is. */
1493 tmp = gfc_finish_block (&body);
1494 gfc_add_expr_to_block (pblock, tmp);
1498 /* Build the implied do-loop. */
1499 stmtblock_t implied_do_block;
1507 loopbody = gfc_finish_block (&body);
1509 /* Create a new block that holds the implied-do loop. A temporary
1510 loop-variable is used. */
1511 gfc_start_block(&implied_do_block);
1513 /* Initialize the loop. */
1514 gfc_init_se (&se, NULL);
1515 gfc_conv_expr_val (&se, c->iterator->start);
1516 gfc_add_block_to_block (&implied_do_block, &se.pre);
1517 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1519 gfc_init_se (&se, NULL);
1520 gfc_conv_expr_val (&se, c->iterator->end);
1521 gfc_add_block_to_block (&implied_do_block, &se.pre);
1522 end = gfc_evaluate_now (se.expr, &implied_do_block);
1524 gfc_init_se (&se, NULL);
1525 gfc_conv_expr_val (&se, c->iterator->step);
1526 gfc_add_block_to_block (&implied_do_block, &se.pre);
1527 step = gfc_evaluate_now (se.expr, &implied_do_block);
1529 /* If this array expands dynamically, and the number of iterations
1530 is not constant, we won't have allocated space for the static
1531 part of C->EXPR's size. Do that now. */
1532 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1534 /* Get the number of iterations. */
1535 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1537 /* Get the static part of C->EXPR's size. */
1538 gfc_get_array_constructor_element_size (&size, c->expr);
1539 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1541 /* Grow the array by TMP * TMP2 elements. */
1542 tmp = fold_build2_loc (input_location, MULT_EXPR,
1543 gfc_array_index_type, tmp, tmp2);
1544 gfc_grow_array (&implied_do_block, desc, tmp);
1547 /* Generate the loop body. */
1548 exit_label = gfc_build_label_decl (NULL_TREE);
1549 gfc_start_block (&body);
1551 /* Generate the exit condition. Depending on the sign of
1552 the step variable we have to generate the correct
1554 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1555 step, build_int_cst (TREE_TYPE (step), 0));
1556 cond = fold_build3_loc (input_location, COND_EXPR,
1557 boolean_type_node, tmp,
1558 fold_build2_loc (input_location, GT_EXPR,
1559 boolean_type_node, shadow_loopvar, end),
1560 fold_build2_loc (input_location, LT_EXPR,
1561 boolean_type_node, shadow_loopvar, end));
1562 tmp = build1_v (GOTO_EXPR, exit_label);
1563 TREE_USED (exit_label) = 1;
1564 tmp = build3_v (COND_EXPR, cond, tmp,
1565 build_empty_stmt (input_location));
1566 gfc_add_expr_to_block (&body, tmp);
1568 /* The main loop body. */
1569 gfc_add_expr_to_block (&body, loopbody);
1571 /* Increase loop variable by step. */
1572 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1573 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1575 gfc_add_modify (&body, shadow_loopvar, tmp);
1577 /* Finish the loop. */
1578 tmp = gfc_finish_block (&body);
1579 tmp = build1_v (LOOP_EXPR, tmp);
1580 gfc_add_expr_to_block (&implied_do_block, tmp);
1582 /* Add the exit label. */
1583 tmp = build1_v (LABEL_EXPR, exit_label);
1584 gfc_add_expr_to_block (&implied_do_block, tmp);
1586 /* Finishe the implied-do loop. */
1587 tmp = gfc_finish_block(&implied_do_block);
1588 gfc_add_expr_to_block(pblock, tmp);
1590 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1597 /* A catch-all to obtain the string length for anything that is not a
1598 a substring of non-constant length, a constant, array or variable. */
1601 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1606 /* Don't bother if we already know the length is a constant. */
1607 if (*len && INTEGER_CST_P (*len))
1610 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1611 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1614 gfc_conv_const_charlen (e->ts.u.cl);
1615 *len = e->ts.u.cl->backend_decl;
1619 /* Otherwise, be brutal even if inefficient. */
1620 ss = gfc_walk_expr (e);
1621 gfc_init_se (&se, NULL);
1623 /* No function call, in case of side effects. */
1624 se.no_function_call = 1;
1625 if (ss == gfc_ss_terminator)
1626 gfc_conv_expr (&se, e);
1628 gfc_conv_expr_descriptor (&se, e, ss);
1630 /* Fix the value. */
1631 *len = gfc_evaluate_now (se.string_length, &se.pre);
1633 gfc_add_block_to_block (block, &se.pre);
1634 gfc_add_block_to_block (block, &se.post);
1636 e->ts.u.cl->backend_decl = *len;
1641 /* Figure out the string length of a variable reference expression.
1642 Used by get_array_ctor_strlen. */
1645 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1651 /* Don't bother if we already know the length is a constant. */
1652 if (*len && INTEGER_CST_P (*len))
1655 ts = &expr->symtree->n.sym->ts;
1656 for (ref = expr->ref; ref; ref = ref->next)
1661 /* Array references don't change the string length. */
1665 /* Use the length of the component. */
1666 ts = &ref->u.c.component->ts;
1670 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1671 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1673 /* Note that this might evaluate expr. */
1674 get_array_ctor_all_strlen (block, expr, len);
1677 mpz_init_set_ui (char_len, 1);
1678 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1679 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1680 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1681 *len = convert (gfc_charlen_type_node, *len);
1682 mpz_clear (char_len);
1690 *len = ts->u.cl->backend_decl;
1694 /* Figure out the string length of a character array constructor.
1695 If len is NULL, don't calculate the length; this happens for recursive calls
1696 when a sub-array-constructor is an element but not at the first position,
1697 so when we're not interested in the length.
1698 Returns TRUE if all elements are character constants. */
1701 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1708 if (gfc_constructor_first (base) == NULL)
1711 *len = build_int_cstu (gfc_charlen_type_node, 0);
1715 /* Loop over all constructor elements to find out is_const, but in len we
1716 want to store the length of the first, not the last, element. We can
1717 of course exit the loop as soon as is_const is found to be false. */
1718 for (c = gfc_constructor_first (base);
1719 c && is_const; c = gfc_constructor_next (c))
1721 switch (c->expr->expr_type)
1724 if (len && !(*len && INTEGER_CST_P (*len)))
1725 *len = build_int_cstu (gfc_charlen_type_node,
1726 c->expr->value.character.length);
1730 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1737 get_array_ctor_var_strlen (block, c->expr, len);
1743 get_array_ctor_all_strlen (block, c->expr, len);
1747 /* After the first iteration, we don't want the length modified. */
1754 /* Check whether the array constructor C consists entirely of constant
1755 elements, and if so returns the number of those elements, otherwise
1756 return zero. Note, an empty or NULL array constructor returns zero. */
1758 unsigned HOST_WIDE_INT
1759 gfc_constant_array_constructor_p (gfc_constructor_base base)
1761 unsigned HOST_WIDE_INT nelem = 0;
1763 gfc_constructor *c = gfc_constructor_first (base);
1767 || c->expr->rank > 0
1768 || c->expr->expr_type != EXPR_CONSTANT)
1770 c = gfc_constructor_next (c);
1777 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1778 and the tree type of it's elements, TYPE, return a static constant
1779 variable that is compile-time initialized. */
1782 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1784 tree tmptype, init, tmp;
1785 HOST_WIDE_INT nelem;
1790 VEC(constructor_elt,gc) *v = NULL;
1792 /* First traverse the constructor list, converting the constants
1793 to tree to build an initializer. */
1795 c = gfc_constructor_first (expr->value.constructor);
1798 gfc_init_se (&se, NULL);
1799 gfc_conv_constant (&se, c->expr);
1800 if (c->expr->ts.type != BT_CHARACTER)
1801 se.expr = fold_convert (type, se.expr);
1802 else if (POINTER_TYPE_P (type))
1803 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1805 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1807 c = gfc_constructor_next (c);
1811 /* Next determine the tree type for the array. We use the gfortran
1812 front-end's gfc_get_nodesc_array_type in order to create a suitable
1813 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1815 memset (&as, 0, sizeof (gfc_array_spec));
1817 as.rank = expr->rank;
1818 as.type = AS_EXPLICIT;
1821 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1822 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1826 for (i = 0; i < expr->rank; i++)
1828 int tmp = (int) mpz_get_si (expr->shape[i]);
1829 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1830 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1834 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1836 /* as is not needed anymore. */
1837 for (i = 0; i < as.rank + as.corank; i++)
1839 gfc_free_expr (as.lower[i]);
1840 gfc_free_expr (as.upper[i]);
1843 init = build_constructor (tmptype, v);
1845 TREE_CONSTANT (init) = 1;
1846 TREE_STATIC (init) = 1;
1848 tmp = gfc_create_var (tmptype, "A");
1849 TREE_STATIC (tmp) = 1;
1850 TREE_CONSTANT (tmp) = 1;
1851 TREE_READONLY (tmp) = 1;
1852 DECL_INITIAL (tmp) = init;
1858 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1859 This mostly initializes the scalarizer state info structure with the
1860 appropriate values to directly use the array created by the function
1861 gfc_build_constant_array_constructor. */
1864 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1865 gfc_ss * ss, tree type)
1871 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1873 info = &ss->data.info;
1875 info->descriptor = tmp;
1876 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1877 info->offset = gfc_index_zero_node;
1879 for (i = 0; i < info->dimen + info->codimen; i++)
1881 info->delta[i] = gfc_index_zero_node;
1882 info->start[i] = gfc_index_zero_node;
1883 info->end[i] = gfc_index_zero_node;
1884 info->stride[i] = gfc_index_one_node;
1887 if (info->dimen > loop->temp_dim)
1888 loop->temp_dim = info->dimen;
1891 /* Helper routine of gfc_trans_array_constructor to determine if the
1892 bounds of the loop specified by LOOP are constant and simple enough
1893 to use with gfc_trans_constant_array_constructor. Returns the
1894 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1897 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1899 tree size = gfc_index_one_node;
1903 for (i = 0; i < loop->dimen; i++)
1905 /* If the bounds aren't constant, return NULL_TREE. */
1906 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1908 if (!integer_zerop (loop->from[i]))
1910 /* Only allow nonzero "from" in one-dimensional arrays. */
1911 if (loop->dimen != 1)
1913 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1914 gfc_array_index_type,
1915 loop->to[i], loop->from[i]);
1919 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1920 tmp, gfc_index_one_node);
1921 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1929 /* Array constructors are handled by constructing a temporary, then using that
1930 within the scalarization loop. This is not optimal, but seems by far the
1934 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1936 gfc_constructor_base c;
1943 bool old_first_len, old_typespec_chararray_ctor;
1944 tree old_first_len_val;
1946 /* Save the old values for nested checking. */
1947 old_first_len = first_len;
1948 old_first_len_val = first_len_val;
1949 old_typespec_chararray_ctor = typespec_chararray_ctor;
1951 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1952 typespec was given for the array constructor. */
1953 typespec_chararray_ctor = (ss->expr->ts.u.cl
1954 && ss->expr->ts.u.cl->length_from_typespec);
1956 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1957 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1959 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1963 gcc_assert (ss->data.info.dimen == loop->dimen);
1965 c = ss->expr->value.constructor;
1966 if (ss->expr->ts.type == BT_CHARACTER)
1970 /* get_array_ctor_strlen walks the elements of the constructor, if a
1971 typespec was given, we already know the string length and want the one
1973 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1974 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1978 const_string = false;
1979 gfc_init_se (&length_se, NULL);
1980 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1981 gfc_charlen_type_node);
1982 ss->string_length = length_se.expr;
1983 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1984 gfc_add_block_to_block (&loop->post, &length_se.post);
1987 const_string = get_array_ctor_strlen (&loop->pre, c,
1988 &ss->string_length);
1990 /* Complex character array constructors should have been taken care of
1991 and not end up here. */
1992 gcc_assert (ss->string_length);
1994 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1996 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1998 type = build_pointer_type (type);
2001 type = gfc_typenode_for_spec (&ss->expr->ts);
2003 /* See if the constructor determines the loop bounds. */
2006 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
2008 /* We have a multidimensional parameter. */
2010 for (n = 0; n < ss->expr->rank; n++)
2012 loop->from[n] = gfc_index_zero_node;
2013 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
2014 gfc_index_integer_kind);
2015 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2016 gfc_array_index_type,
2017 loop->to[n], gfc_index_one_node);
2021 if (loop->to[0] == NULL_TREE)
2025 /* We should have a 1-dimensional, zero-based loop. */
2026 gcc_assert (loop->dimen == 1);
2027 gcc_assert (integer_zerop (loop->from[0]));
2029 /* Split the constructor size into a static part and a dynamic part.
2030 Allocate the static size up-front and record whether the dynamic
2031 size might be nonzero. */
2033 dynamic = gfc_get_array_constructor_size (&size, c);
2034 mpz_sub_ui (size, size, 1);
2035 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2039 /* Special case constant array constructors. */
2042 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2045 tree size = constant_array_constructor_loop_size (loop);
2046 if (size && compare_tree_int (size, nelem) == 0)
2048 gfc_trans_constant_array_constructor (loop, ss, type);
2054 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2057 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
2058 type, NULL_TREE, dynamic, true, false, where);
2060 desc = ss->data.info.descriptor;
2061 offset = gfc_index_zero_node;
2062 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2063 TREE_NO_WARNING (offsetvar) = 1;
2064 TREE_USED (offsetvar) = 0;
2065 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2066 &offset, &offsetvar, dynamic);
2068 /* If the array grows dynamically, the upper bound of the loop variable
2069 is determined by the array's final upper bound. */
2072 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2073 gfc_array_index_type,
2074 offsetvar, gfc_index_one_node);
2075 tmp = gfc_evaluate_now (tmp, &loop->pre);
2076 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2077 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2078 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2083 if (TREE_USED (offsetvar))
2084 pushdecl (offsetvar);
2086 gcc_assert (INTEGER_CST_P (offset));
2089 /* Disable bound checking for now because it's probably broken. */
2090 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2097 /* Restore old values of globals. */
2098 first_len = old_first_len;
2099 first_len_val = old_first_len_val;
2100 typespec_chararray_ctor = old_typespec_chararray_ctor;
2104 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2105 called after evaluating all of INFO's vector dimensions. Go through
2106 each such vector dimension and see if we can now fill in any missing
2110 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2119 for (n = 0; n < loop->dimen + loop->codimen; n++)
2122 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2123 && loop->to[n] == NULL)
2125 /* Loop variable N indexes vector dimension DIM, and we don't
2126 yet know the upper bound of loop variable N. Set it to the
2127 difference between the vector's upper and lower bounds. */
2128 gcc_assert (loop->from[n] == gfc_index_zero_node);
2129 gcc_assert (info->subscript[dim]
2130 && info->subscript[dim]->type == GFC_SS_VECTOR);
2132 gfc_init_se (&se, NULL);
2133 desc = info->subscript[dim]->data.info.descriptor;
2134 zero = gfc_rank_cst[0];
2135 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2136 gfc_array_index_type,
2137 gfc_conv_descriptor_ubound_get (desc, zero),
2138 gfc_conv_descriptor_lbound_get (desc, zero));
2139 tmp = gfc_evaluate_now (tmp, &loop->pre);
2146 /* Add the pre and post chains for all the scalar expressions in a SS chain
2147 to loop. This is called after the loop parameters have been calculated,
2148 but before the actual scalarizing loops. */
2151 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2157 /* TODO: This can generate bad code if there are ordering dependencies,
2158 e.g., a callee allocated function and an unknown size constructor. */
2159 gcc_assert (ss != NULL);
2161 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2168 /* Scalar expression. Evaluate this now. This includes elemental
2169 dimension indices, but not array section bounds. */
2170 gfc_init_se (&se, NULL);
2171 gfc_conv_expr (&se, ss->expr);
2172 gfc_add_block_to_block (&loop->pre, &se.pre);
2174 if (ss->expr->ts.type != BT_CHARACTER)
2176 /* Move the evaluation of scalar expressions outside the
2177 scalarization loop, except for WHERE assignments. */
2179 se.expr = convert(gfc_array_index_type, se.expr);
2181 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2182 gfc_add_block_to_block (&loop->pre, &se.post);
2185 gfc_add_block_to_block (&loop->post, &se.post);
2187 ss->data.scalar.expr = se.expr;
2188 ss->string_length = se.string_length;
2191 case GFC_SS_REFERENCE:
2192 /* Scalar argument to elemental procedure. Evaluate this
2194 gfc_init_se (&se, NULL);
2195 gfc_conv_expr (&se, ss->expr);
2196 gfc_add_block_to_block (&loop->pre, &se.pre);
2197 gfc_add_block_to_block (&loop->post, &se.post);
2199 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2200 ss->string_length = se.string_length;
2203 case GFC_SS_SECTION:
2204 /* Add the expressions for scalar and vector subscripts. */
2205 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2206 if (ss->data.info.subscript[n])
2207 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2210 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2214 /* Get the vector's descriptor and store it in SS. */
2215 gfc_init_se (&se, NULL);
2216 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2217 gfc_add_block_to_block (&loop->pre, &se.pre);
2218 gfc_add_block_to_block (&loop->post, &se.post);
2219 ss->data.info.descriptor = se.expr;
2222 case GFC_SS_INTRINSIC:
2223 gfc_add_intrinsic_ss_code (loop, ss);
2226 case GFC_SS_FUNCTION:
2227 /* Array function return value. We call the function and save its
2228 result in a temporary for use inside the loop. */
2229 gfc_init_se (&se, NULL);
2232 gfc_conv_expr (&se, ss->expr);
2233 gfc_add_block_to_block (&loop->pre, &se.pre);
2234 gfc_add_block_to_block (&loop->post, &se.post);
2235 ss->string_length = se.string_length;
2238 case GFC_SS_CONSTRUCTOR:
2239 if (ss->expr->ts.type == BT_CHARACTER
2240 && ss->string_length == NULL
2241 && ss->expr->ts.u.cl
2242 && ss->expr->ts.u.cl->length)
2244 gfc_init_se (&se, NULL);
2245 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2246 gfc_charlen_type_node);
2247 ss->string_length = se.expr;
2248 gfc_add_block_to_block (&loop->pre, &se.pre);
2249 gfc_add_block_to_block (&loop->post, &se.post);
2251 gfc_trans_array_constructor (loop, ss, where);
2255 case GFC_SS_COMPONENT:
2256 /* Do nothing. These are handled elsewhere. */
2266 /* Translate expressions for the descriptor and data pointer of a SS. */
2270 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2275 /* Get the descriptor for the array to be scalarized. */
2276 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2277 gfc_init_se (&se, NULL);
2278 se.descriptor_only = 1;
2279 gfc_conv_expr_lhs (&se, ss->expr);
2280 gfc_add_block_to_block (block, &se.pre);
2281 ss->data.info.descriptor = se.expr;
2282 ss->string_length = se.string_length;
2286 /* Also the data pointer. */
2287 tmp = gfc_conv_array_data (se.expr);
2288 /* If this is a variable or address of a variable we use it directly.
2289 Otherwise we must evaluate it now to avoid breaking dependency
2290 analysis by pulling the expressions for elemental array indices
2293 || (TREE_CODE (tmp) == ADDR_EXPR
2294 && DECL_P (TREE_OPERAND (tmp, 0)))))
2295 tmp = gfc_evaluate_now (tmp, block);
2296 ss->data.info.data = tmp;
2298 tmp = gfc_conv_array_offset (se.expr);
2299 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2301 /* Make absolutely sure that the saved_offset is indeed saved
2302 so that the variable is still accessible after the loops
2304 ss->data.info.saved_offset = ss->data.info.offset;
2309 /* Initialize a gfc_loopinfo structure. */
2312 gfc_init_loopinfo (gfc_loopinfo * loop)
2316 memset (loop, 0, sizeof (gfc_loopinfo));
2317 gfc_init_block (&loop->pre);
2318 gfc_init_block (&loop->post);
2320 /* Initially scalarize in order and default to no loop reversal. */
2321 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2324 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2327 loop->ss = gfc_ss_terminator;
2331 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2335 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2341 /* Return an expression for the data pointer of an array. */
2344 gfc_conv_array_data (tree descriptor)
2348 type = TREE_TYPE (descriptor);
2349 if (GFC_ARRAY_TYPE_P (type))
2351 if (TREE_CODE (type) == POINTER_TYPE)
2355 /* Descriptorless arrays. */
2356 return gfc_build_addr_expr (NULL_TREE, descriptor);
2360 return gfc_conv_descriptor_data_get (descriptor);
2364 /* Return an expression for the base offset of an array. */
2367 gfc_conv_array_offset (tree descriptor)
2371 type = TREE_TYPE (descriptor);
2372 if (GFC_ARRAY_TYPE_P (type))
2373 return GFC_TYPE_ARRAY_OFFSET (type);
2375 return gfc_conv_descriptor_offset_get (descriptor);
2379 /* Get an expression for the array stride. */
2382 gfc_conv_array_stride (tree descriptor, int dim)
2387 type = TREE_TYPE (descriptor);
2389 /* For descriptorless arrays use the array size. */
2390 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2391 if (tmp != NULL_TREE)
2394 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2399 /* Like gfc_conv_array_stride, but for the lower bound. */
2402 gfc_conv_array_lbound (tree descriptor, int dim)
2407 type = TREE_TYPE (descriptor);
2409 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2410 if (tmp != NULL_TREE)
2413 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2418 /* Like gfc_conv_array_stride, but for the upper bound. */
2421 gfc_conv_array_ubound (tree descriptor, int dim)
2426 type = TREE_TYPE (descriptor);
2428 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2429 if (tmp != NULL_TREE)
2432 /* This should only ever happen when passing an assumed shape array
2433 as an actual parameter. The value will never be used. */
2434 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2435 return gfc_index_zero_node;
2437 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2442 /* Generate code to perform an array index bound check. */
2445 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2446 locus * where, bool check_upper)
2449 tree tmp_lo, tmp_up;
2451 const char * name = NULL;
2453 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2456 index = gfc_evaluate_now (index, &se->pre);
2458 /* We find a name for the error message. */
2460 name = se->ss->expr->symtree->name;
2462 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2463 && se->loop->ss->expr->symtree)
2464 name = se->loop->ss->expr->symtree->name;
2466 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2467 && se->loop->ss->loop_chain->expr
2468 && se->loop->ss->loop_chain->expr->symtree)
2469 name = se->loop->ss->loop_chain->expr->symtree->name;
2471 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2473 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2474 && se->loop->ss->expr->value.function.name)
2475 name = se->loop->ss->expr->value.function.name;
2477 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2478 || se->loop->ss->type == GFC_SS_SCALAR)
2479 name = "unnamed constant";
2482 if (TREE_CODE (descriptor) == VAR_DECL)
2483 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2485 /* If upper bound is present, include both bounds in the error message. */
2488 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2489 tmp_up = gfc_conv_array_ubound (descriptor, n);
2492 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2493 "outside of expected range (%%ld:%%ld)", n+1, name);
2495 asprintf (&msg, "Index '%%ld' of dimension %d "
2496 "outside of expected range (%%ld:%%ld)", n+1);
2498 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2500 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2501 fold_convert (long_integer_type_node, index),
2502 fold_convert (long_integer_type_node, tmp_lo),
2503 fold_convert (long_integer_type_node, tmp_up));
2504 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2506 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2507 fold_convert (long_integer_type_node, index),
2508 fold_convert (long_integer_type_node, tmp_lo),
2509 fold_convert (long_integer_type_node, tmp_up));
2514 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2517 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2518 "below lower bound of %%ld", n+1, name);
2520 asprintf (&msg, "Index '%%ld' of dimension %d "
2521 "below lower bound of %%ld", n+1);
2523 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2525 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2526 fold_convert (long_integer_type_node, index),
2527 fold_convert (long_integer_type_node, tmp_lo));
2535 /* Return the offset for an index. Performs bound checking for elemental
2536 dimensions. Single element references are processed separately.
2537 DIM is the array dimension, I is the loop dimension. */
2540 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2541 gfc_array_ref * ar, tree stride)
2547 /* Get the index into the array for this dimension. */
2550 gcc_assert (ar->type != AR_ELEMENT);
2551 switch (ar->dimen_type[dim])
2553 case DIMEN_THIS_IMAGE:
2557 /* Elemental dimension. */
2558 gcc_assert (info->subscript[dim]
2559 && info->subscript[dim]->type == GFC_SS_SCALAR);
2560 /* We've already translated this value outside the loop. */
2561 index = info->subscript[dim]->data.scalar.expr;
2563 index = gfc_trans_array_bound_check (se, info->descriptor,
2564 index, dim, &ar->where,
2565 ar->as->type != AS_ASSUMED_SIZE
2566 || dim < ar->dimen - 1);
2570 gcc_assert (info && se->loop);
2571 gcc_assert (info->subscript[dim]
2572 && info->subscript[dim]->type == GFC_SS_VECTOR);
2573 desc = info->subscript[dim]->data.info.descriptor;
2575 /* Get a zero-based index into the vector. */
2576 index = fold_build2_loc (input_location, MINUS_EXPR,
2577 gfc_array_index_type,
2578 se->loop->loopvar[i], se->loop->from[i]);
2580 /* Multiply the index by the stride. */
2581 index = fold_build2_loc (input_location, MULT_EXPR,
2582 gfc_array_index_type,
2583 index, gfc_conv_array_stride (desc, 0));
2585 /* Read the vector to get an index into info->descriptor. */
2586 data = build_fold_indirect_ref_loc (input_location,
2587 gfc_conv_array_data (desc));
2588 index = gfc_build_array_ref (data, index, NULL);
2589 index = gfc_evaluate_now (index, &se->pre);
2590 index = fold_convert (gfc_array_index_type, index);
2592 /* Do any bounds checking on the final info->descriptor index. */
2593 index = gfc_trans_array_bound_check (se, info->descriptor,
2594 index, dim, &ar->where,
2595 ar->as->type != AS_ASSUMED_SIZE
2596 || dim < ar->dimen - 1);
2600 /* Scalarized dimension. */
2601 gcc_assert (info && se->loop);
2603 /* Multiply the loop variable by the stride and delta. */
2604 index = se->loop->loopvar[i];
2605 if (!integer_onep (info->stride[dim]))
2606 index = fold_build2_loc (input_location, MULT_EXPR,
2607 gfc_array_index_type, index,
2609 if (!integer_zerop (info->delta[dim]))
2610 index = fold_build2_loc (input_location, PLUS_EXPR,
2611 gfc_array_index_type, index,
2621 /* Temporary array or derived type component. */
2622 gcc_assert (se->loop);
2623 index = se->loop->loopvar[se->loop->order[i]];
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 /* Generate the code to be executed immediately before entering a
2834 scalarization loop. */
2837 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2838 stmtblock_t * pblock)
2847 /* This code will be executed before entering the scalarization loop
2848 for this dimension. */
2849 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2851 if ((ss->useflags & flag) == 0)
2854 if (ss->type != GFC_SS_SECTION
2855 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2856 && ss->type != GFC_SS_COMPONENT)
2859 info = &ss->data.info;
2861 if (dim >= info->dimen)
2864 if (dim == info->dimen - 1)
2866 /* For the outermost loop calculate the offset due to any
2867 elemental dimensions. It will have been initialized with the
2868 base offset of the array. */
2871 for (i = 0; i < info->ref->u.ar.dimen; i++)
2873 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2876 gfc_init_se (&se, NULL);
2878 se.expr = info->descriptor;
2879 stride = gfc_conv_array_stride (info->descriptor, i);
2880 index = gfc_conv_array_index_offset (&se, info, i, -1,
2883 gfc_add_block_to_block (pblock, &se.pre);
2885 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2886 gfc_array_index_type,
2887 info->offset, index);
2888 info->offset = gfc_evaluate_now (info->offset, pblock);
2893 /* For the time being, the innermost loop is unconditionally on
2894 the first dimension of the scalarization loop. */
2895 gcc_assert (i == 0);
2896 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2898 /* Calculate the stride of the innermost loop. Hopefully this will
2899 allow the backend optimizers to do their stuff more effectively.
2901 info->stride0 = gfc_evaluate_now (stride, pblock);
2905 /* Add the offset for the previous loop dimension. */
2910 ar = &info->ref->u.ar;
2911 i = loop->order[dim + 1];
2919 gfc_init_se (&se, NULL);
2921 se.expr = info->descriptor;
2922 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2923 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2925 gfc_add_block_to_block (pblock, &se.pre);
2926 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2927 gfc_array_index_type, info->offset,
2929 info->offset = gfc_evaluate_now (info->offset, pblock);
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 + loop->codimen - 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 + loop->codimen; 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,
3216 bool coarray, bool coarray_last)
3218 gfc_expr *stride = NULL;
3224 gcc_assert (ss->type == GFC_SS_SECTION);
3226 info = &ss->data.info;
3227 ar = &info->ref->u.ar;
3229 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3231 /* We use a zero-based index to access the vector. */
3232 info->start[dim] = gfc_index_zero_node;
3233 info->end[dim] = NULL;
3235 info->stride[dim] = gfc_index_one_node;
3239 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3240 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3241 desc = info->descriptor;
3243 stride = ar->stride[dim];
3245 /* Calculate the start of the range. For vector subscripts this will
3246 be the range of the vector. */
3247 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3249 /* Similarly calculate the end. Although this is not used in the
3250 scalarizer, it is needed when checking bounds and where the end
3251 is an expression with side-effects. */
3253 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3255 /* Calculate the stride. */
3256 if (!coarray && stride == NULL)
3257 info->stride[dim] = gfc_index_one_node;
3260 gfc_init_se (&se, NULL);
3261 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3262 gfc_add_block_to_block (&loop->pre, &se.pre);
3263 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3268 /* Calculates the range start and stride for a SS chain. Also gets the
3269 descriptor and data pointer. The range of vector subscripts is the size
3270 of the vector. Array bounds are also checked. */
3273 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3281 /* Determine the rank of the loop. */
3282 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3286 case GFC_SS_SECTION:
3287 case GFC_SS_CONSTRUCTOR:
3288 case GFC_SS_FUNCTION:
3289 case GFC_SS_COMPONENT:
3290 loop->dimen = ss->data.info.dimen;
3291 loop->codimen = ss->data.info.codimen;
3294 /* As usual, lbound and ubound are exceptions!. */
3295 case GFC_SS_INTRINSIC:
3296 switch (ss->expr->value.function.isym->id)
3298 case GFC_ISYM_LBOUND:
3299 case GFC_ISYM_UBOUND:
3300 loop->dimen = ss->data.info.dimen;
3304 case GFC_ISYM_LCOBOUND:
3305 case GFC_ISYM_UCOBOUND:
3306 case GFC_ISYM_THIS_IMAGE:
3307 loop->dimen = ss->data.info.dimen;
3308 loop->codimen = ss->data.info.codimen;
3320 /* We should have determined the rank of the expression by now. If
3321 not, that's bad news. */
3325 /* Loop over all the SS in the chain. */
3326 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3328 if (ss->expr && ss->expr->shape && !ss->shape)
3329 ss->shape = ss->expr->shape;
3333 case GFC_SS_SECTION:
3334 /* Get the descriptor for the array. */
3335 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3337 for (n = 0; n < ss->data.info.dimen; n++)
3338 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3340 for (n = ss->data.info.dimen;
3341 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3342 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3343 n == ss->data.info.dimen
3344 + ss->data.info.codimen -1);
3348 case GFC_SS_INTRINSIC:
3349 switch (ss->expr->value.function.isym->id)
3351 /* Fall through to supply start and stride. */
3352 case GFC_ISYM_LBOUND:
3353 case GFC_ISYM_UBOUND:
3354 case GFC_ISYM_LCOBOUND:
3355 case GFC_ISYM_UCOBOUND:
3356 case GFC_ISYM_THIS_IMAGE:
3363 case GFC_SS_CONSTRUCTOR:
3364 case GFC_SS_FUNCTION:
3365 for (n = 0; n < ss->data.info.dimen; n++)
3367 ss->data.info.start[n] = gfc_index_zero_node;
3368 ss->data.info.end[n] = gfc_index_zero_node;
3369 ss->data.info.stride[n] = gfc_index_one_node;
3378 /* The rest is just runtime bound checking. */
3379 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3382 tree lbound, ubound;
3384 tree size[GFC_MAX_DIMENSIONS];
3385 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3390 gfc_start_block (&block);
3392 for (n = 0; n < loop->dimen; n++)
3393 size[n] = NULL_TREE;
3395 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3399 if (ss->type != GFC_SS_SECTION)
3402 /* Catch allocatable lhs in f2003. */
3403 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3406 gfc_start_block (&inner);
3408 /* TODO: range checking for mapped dimensions. */
3409 info = &ss->data.info;
3411 /* This code only checks ranges. Elemental and vector
3412 dimensions are checked later. */
3413 for (n = 0; n < loop->dimen; n++)
3418 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3421 if (dim == info->ref->u.ar.dimen - 1
3422 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3423 check_upper = false;
3427 /* Zero stride is not allowed. */
3428 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3429 info->stride[dim], gfc_index_zero_node);
3430 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3431 "of array '%s'", dim + 1, ss->expr->symtree->name);
3432 gfc_trans_runtime_check (true, false, tmp, &inner,
3433 &ss->expr->where, msg);
3436 desc = ss->data.info.descriptor;
3438 /* This is the run-time equivalent of resolve.c's
3439 check_dimension(). The logical is more readable there
3440 than it is here, with all the trees. */
3441 lbound = gfc_conv_array_lbound (desc, dim);
3442 end = info->end[dim];
3444 ubound = gfc_conv_array_ubound (desc, dim);
3448 /* non_zerosized is true when the selected range is not
3450 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3451 boolean_type_node, info->stride[dim],
3452 gfc_index_zero_node);
3453 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3454 info->start[dim], end);
3455 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3456 boolean_type_node, stride_pos, tmp);
3458 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3460 info->stride[dim], gfc_index_zero_node);
3461 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3462 info->start[dim], end);
3463 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3466 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3468 stride_pos, stride_neg);
3470 /* Check the start of the range against the lower and upper
3471 bounds of the array, if the range is not empty.
3472 If upper bound is present, include both bounds in the
3476 tmp = fold_build2_loc (input_location, LT_EXPR,
3478 info->start[dim], lbound);
3479 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3481 non_zerosized, tmp);
3482 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3484 info->start[dim], ubound);
3485 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3487 non_zerosized, tmp2);
3488 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3489 "outside of expected range (%%ld:%%ld)",
3490 dim + 1, ss->expr->symtree->name);
3491 gfc_trans_runtime_check (true, false, tmp, &inner,
3492 &ss->expr->where, msg,
3493 fold_convert (long_integer_type_node, info->start[dim]),
3494 fold_convert (long_integer_type_node, lbound),
3495 fold_convert (long_integer_type_node, ubound));
3496 gfc_trans_runtime_check (true, false, tmp2, &inner,
3497 &ss->expr->where, msg,
3498 fold_convert (long_integer_type_node, info->start[dim]),
3499 fold_convert (long_integer_type_node, lbound),
3500 fold_convert (long_integer_type_node, ubound));
3505 tmp = fold_build2_loc (input_location, LT_EXPR,
3507 info->start[dim], lbound);
3508 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3509 boolean_type_node, non_zerosized, tmp);
3510 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3511 "below lower bound of %%ld",
3512 dim + 1, ss->expr->symtree->name);
3513 gfc_trans_runtime_check (true, false, tmp, &inner,
3514 &ss->expr->where, msg,
3515 fold_convert (long_integer_type_node, info->start[dim]),
3516 fold_convert (long_integer_type_node, lbound));
3520 /* Compute the last element of the range, which is not
3521 necessarily "end" (think 0:5:3, which doesn't contain 5)
3522 and check it against both lower and upper bounds. */
3524 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3525 gfc_array_index_type, end,
3527 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3528 gfc_array_index_type, tmp,
3530 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3531 gfc_array_index_type, end, tmp);
3532 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3533 boolean_type_node, tmp, lbound);
3534 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3535 boolean_type_node, non_zerosized, tmp2);
3538 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3539 boolean_type_node, tmp, ubound);
3540 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3541 boolean_type_node, non_zerosized, tmp3);
3542 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3543 "outside of expected range (%%ld:%%ld)",
3544 dim + 1, ss->expr->symtree->name);
3545 gfc_trans_runtime_check (true, false, tmp2, &inner,
3546 &ss->expr->where, msg,
3547 fold_convert (long_integer_type_node, tmp),
3548 fold_convert (long_integer_type_node, ubound),
3549 fold_convert (long_integer_type_node, lbound));
3550 gfc_trans_runtime_check (true, false, tmp3, &inner,
3551 &ss->expr->where, msg,
3552 fold_convert (long_integer_type_node, tmp),
3553 fold_convert (long_integer_type_node, ubound),
3554 fold_convert (long_integer_type_node, lbound));
3559 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3560 "below lower bound of %%ld",
3561 dim + 1, ss->expr->symtree->name);
3562 gfc_trans_runtime_check (true, false, tmp2, &inner,
3563 &ss->expr->where, msg,
3564 fold_convert (long_integer_type_node, tmp),
3565 fold_convert (long_integer_type_node, lbound));
3569 /* Check the section sizes match. */
3570 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3571 gfc_array_index_type, end,
3573 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3574 gfc_array_index_type, tmp,
3576 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3577 gfc_array_index_type,
3578 gfc_index_one_node, tmp);
3579 tmp = fold_build2_loc (input_location, MAX_EXPR,
3580 gfc_array_index_type, tmp,
3581 build_int_cst (gfc_array_index_type, 0));
3582 /* We remember the size of the first section, and check all the
3583 others against this. */
3586 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3587 boolean_type_node, tmp, size[n]);
3588 asprintf (&msg, "Array bound mismatch for dimension %d "
3589 "of array '%s' (%%ld/%%ld)",
3590 dim + 1, ss->expr->symtree->name);
3592 gfc_trans_runtime_check (true, false, tmp3, &inner,
3593 &ss->expr->where, msg,
3594 fold_convert (long_integer_type_node, tmp),
3595 fold_convert (long_integer_type_node, size[n]));
3600 size[n] = gfc_evaluate_now (tmp, &inner);
3603 tmp = gfc_finish_block (&inner);
3605 /* For optional arguments, only check bounds if the argument is
3607 if (ss->expr->symtree->n.sym->attr.optional
3608 || ss->expr->symtree->n.sym->attr.not_always_present)
3609 tmp = build3_v (COND_EXPR,
3610 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3611 tmp, build_empty_stmt (input_location));
3613 gfc_add_expr_to_block (&block, tmp);
3617 tmp = gfc_finish_block (&block);
3618 gfc_add_expr_to_block (&loop->pre, tmp);
3622 /* Return true if both symbols could refer to the same data object. Does
3623 not take account of aliasing due to equivalence statements. */
3626 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3627 bool lsym_target, bool rsym_pointer, bool rsym_target)
3629 /* Aliasing isn't possible if the symbols have different base types. */
3630 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3633 /* Pointers can point to other pointers and target objects. */
3635 if ((lsym_pointer && (rsym_pointer || rsym_target))
3636 || (rsym_pointer && (lsym_pointer || lsym_target)))
3639 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3640 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3642 if (lsym_target && rsym_target
3643 && ((lsym->attr.dummy && !lsym->attr.contiguous
3644 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3645 || (rsym->attr.dummy && !rsym->attr.contiguous
3646 && (!rsym->attr.dimension
3647 || rsym->as->type == AS_ASSUMED_SHAPE))))
3654 /* Return true if the two SS could be aliased, i.e. both point to the same data
3656 /* TODO: resolve aliases based on frontend expressions. */
3659 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3665 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3667 lsym = lss->expr->symtree->n.sym;
3668 rsym = rss->expr->symtree->n.sym;
3670 lsym_pointer = lsym->attr.pointer;
3671 lsym_target = lsym->attr.target;
3672 rsym_pointer = rsym->attr.pointer;
3673 rsym_target = rsym->attr.target;
3675 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3676 rsym_pointer, rsym_target))
3679 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3680 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3683 /* For derived types we must check all the component types. We can ignore
3684 array references as these will have the same base type as the previous
3686 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3688 if (lref->type != REF_COMPONENT)
3691 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3692 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3694 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3695 rsym_pointer, rsym_target))
3698 if ((lsym_pointer && (rsym_pointer || rsym_target))
3699 || (rsym_pointer && (lsym_pointer || lsym_target)))
3701 if (gfc_compare_types (&lref->u.c.component->ts,
3706 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3709 if (rref->type != REF_COMPONENT)
3712 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3713 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3715 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3716 lsym_pointer, lsym_target,
3717 rsym_pointer, rsym_target))
3720 if ((lsym_pointer && (rsym_pointer || rsym_target))
3721 || (rsym_pointer && (lsym_pointer || lsym_target)))
3723 if (gfc_compare_types (&lref->u.c.component->ts,
3724 &rref->u.c.sym->ts))
3726 if (gfc_compare_types (&lref->u.c.sym->ts,
3727 &rref->u.c.component->ts))
3729 if (gfc_compare_types (&lref->u.c.component->ts,
3730 &rref->u.c.component->ts))
3736 lsym_pointer = lsym->attr.pointer;
3737 lsym_target = lsym->attr.target;
3738 lsym_pointer = lsym->attr.pointer;
3739 lsym_target = lsym->attr.target;
3741 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3743 if (rref->type != REF_COMPONENT)
3746 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3747 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3749 if (symbols_could_alias (rref->u.c.sym, lsym,
3750 lsym_pointer, lsym_target,
3751 rsym_pointer, rsym_target))
3754 if ((lsym_pointer && (rsym_pointer || rsym_target))
3755 || (rsym_pointer && (lsym_pointer || lsym_target)))
3757 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3766 /* Resolve array data dependencies. Creates a temporary if required. */
3767 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3771 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3780 loop->temp_ss = NULL;
3782 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3784 if (ss->type != GFC_SS_SECTION)
3787 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3789 if (gfc_could_be_alias (dest, ss)
3790 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3798 lref = dest->expr->ref;
3799 rref = ss->expr->ref;
3801 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3806 for (i = 0; i < dest->data.info.dimen; i++)
3807 for (j = 0; j < ss->data.info.dimen; j++)
3809 && dest->data.info.dim[i] == ss->data.info.dim[j])
3811 /* If we don't access array elements in the same order,
3812 there is a dependency. */
3817 /* TODO : loop shifting. */
3820 /* Mark the dimensions for LOOP SHIFTING */
3821 for (n = 0; n < loop->dimen; n++)
3823 int dim = dest->data.info.dim[n];
3825 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3827 else if (! gfc_is_same_range (&lref->u.ar,
3828 &rref->u.ar, dim, 0))
3832 /* Put all the dimensions with dependencies in the
3835 for (n = 0; n < loop->dimen; n++)
3837 gcc_assert (loop->order[n] == n);
3839 loop->order[dim++] = n;
3841 for (n = 0; n < loop->dimen; n++)
3844 loop->order[dim++] = n;
3847 gcc_assert (dim == loop->dimen);
3858 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3859 if (GFC_ARRAY_TYPE_P (base_type)
3860 || GFC_DESCRIPTOR_TYPE_P (base_type))
3861 base_type = gfc_get_element_type (base_type);
3862 loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
3864 loop->temp_ss->data.temp.codimen = loop->codimen;
3865 gfc_add_ss_to_loop (loop, loop->temp_ss);
3868 loop->temp_ss = NULL;
3872 /* Initialize the scalarization loop. Creates the loop variables. Determines
3873 the range of the loop variables. Creates a temporary if required.
3874 Calculates how to transform from loop variables to array indices for each
3875 expression. Also generates code for scalar expressions which have been
3876 moved outside the loop. */
3879 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3881 int n, dim, spec_dim;
3883 gfc_ss_info *specinfo;
3886 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3887 bool dynamic[GFC_MAX_DIMENSIONS];
3892 for (n = 0; n < loop->dimen + loop->codimen; n++)
3896 /* We use one SS term, and use that to determine the bounds of the
3897 loop for this dimension. We try to pick the simplest term. */
3898 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3900 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3903 info = &ss->data.info;
3906 if (loopspec[n] != NULL)
3908 specinfo = &loopspec[n]->data.info;
3909 spec_dim = specinfo->dim[n];
3913 /* Silence unitialized warnings. */
3920 gcc_assert (ss->shape[dim]);
3921 /* The frontend has worked out the size for us. */
3923 || !loopspec[n]->shape
3924 || !integer_zerop (specinfo->start[spec_dim]))
3925 /* Prefer zero-based descriptors if possible. */
3930 if (ss->type == GFC_SS_CONSTRUCTOR)
3932 gfc_constructor_base base;
3933 /* An unknown size constructor will always be rank one.
3934 Higher rank constructors will either have known shape,
3935 or still be wrapped in a call to reshape. */
3936 gcc_assert (loop->dimen == 1);
3938 /* Always prefer to use the constructor bounds if the size
3939 can be determined at compile time. Prefer not to otherwise,
3940 since the general case involves realloc, and it's better to
3941 avoid that overhead if possible. */
3942 base = ss->expr->value.constructor;
3943 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3944 if (!dynamic[n] || !loopspec[n])
3949 /* TODO: Pick the best bound if we have a choice between a
3950 function and something else. */
3951 if (ss->type == GFC_SS_FUNCTION)
3957 /* Avoid using an allocatable lhs in an assignment, since
3958 there might be a reallocation coming. */
3959 if (loopspec[n] && ss->is_alloc_lhs)
3962 if (ss->type != GFC_SS_SECTION)
3967 /* Criteria for choosing a loop specifier (most important first):
3968 doesn't need realloc
3974 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3975 || n >= loop->dimen)
3977 else if (integer_onep (info->stride[dim])
3978 && !integer_onep (specinfo->stride[spec_dim]))
3980 else if (INTEGER_CST_P (info->stride[dim])
3981 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3983 else if (INTEGER_CST_P (info->start[dim])
3984 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3986 /* We don't work out the upper bound.
3987 else if (INTEGER_CST_P (info->finish[n])
3988 && ! INTEGER_CST_P (specinfo->finish[n]))
3989 loopspec[n] = ss; */
3992 /* We should have found the scalarization loop specifier. If not,
3994 gcc_assert (loopspec[n]);
3996 info = &loopspec[n]->data.info;
3999 /* Set the extents of this range. */
4000 cshape = loopspec[n]->shape;
4001 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
4002 && INTEGER_CST_P (info->stride[dim]))
4004 loop->from[n] = info->start[dim];
4005 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
4006 mpz_sub_ui (i, i, 1);
4007 /* To = from + (size - 1) * stride. */
4008 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4009 if (!integer_onep (info->stride[dim]))
4010 tmp = fold_build2_loc (input_location, MULT_EXPR,
4011 gfc_array_index_type, tmp,
4013 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4014 gfc_array_index_type,
4015 loop->from[n], tmp);
4019 loop->from[n] = info->start[dim];
4020 switch (loopspec[n]->type)
4022 case GFC_SS_CONSTRUCTOR:
4023 /* The upper bound is calculated when we expand the
4025 gcc_assert (loop->to[n] == NULL_TREE);
4028 case GFC_SS_SECTION:
4029 /* Use the end expression if it exists and is not constant,
4030 so that it is only evaluated once. */
4031 loop->to[n] = info->end[dim];
4034 case GFC_SS_FUNCTION:
4035 /* The loop bound will be set when we generate the call. */
4036 gcc_assert (loop->to[n] == NULL_TREE);
4044 /* Transform everything so we have a simple incrementing variable. */
4045 if (n < loop->dimen && integer_onep (info->stride[dim]))
4046 info->delta[dim] = gfc_index_zero_node;
4047 else if (n < loop->dimen)
4049 /* Set the delta for this section. */
4050 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4051 /* Number of iterations is (end - start + step) / step.
4052 with start = 0, this simplifies to
4054 for (i = 0; i<=last; i++){...}; */
4055 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4056 gfc_array_index_type, loop->to[n],
4058 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4059 gfc_array_index_type, tmp, info->stride[dim]);
4060 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4061 tmp, build_int_cst (gfc_array_index_type, -1));
4062 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4063 /* Make the loop variable start at 0. */
4064 loop->from[n] = gfc_index_zero_node;
4068 /* Add all the scalar code that can be taken out of the loops.
4069 This may include calculating the loop bounds, so do it before
4070 allocating the temporary. */
4071 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4073 /* If we want a temporary then create it. */
4074 if (loop->temp_ss != NULL)
4076 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
4078 /* Make absolutely sure that this is a complete type. */
4079 if (loop->temp_ss->string_length)
4080 loop->temp_ss->data.temp.type
4081 = gfc_get_character_type_len_for_eltype
4082 (TREE_TYPE (loop->temp_ss->data.temp.type),
4083 loop->temp_ss->string_length);
4085 tmp = loop->temp_ss->data.temp.type;
4086 n = loop->temp_ss->data.temp.dimen;
4087 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
4088 loop->temp_ss->type = GFC_SS_SECTION;
4089 loop->temp_ss->data.info.dimen = n;
4091 gcc_assert (loop->temp_ss->data.info.dimen != 0);
4092 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
4093 loop->temp_ss->data.info.dim[n] = n;
4095 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4096 &loop->temp_ss->data.info, tmp, NULL_TREE,
4097 false, true, false, where);
4100 for (n = 0; n < loop->temp_dim; n++)
4101 loopspec[loop->order[n]] = NULL;
4105 /* For array parameters we don't have loop variables, so don't calculate the
4107 if (loop->array_parameter)
4110 /* Calculate the translation from loop variables to array indices. */
4111 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4113 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4114 && ss->type != GFC_SS_CONSTRUCTOR)
4118 info = &ss->data.info;
4120 for (n = 0; n < info->dimen; n++)
4122 /* If we are specifying the range the delta is already set. */
4123 if (loopspec[n] != ss)
4125 dim = ss->data.info.dim[n];
4127 /* Calculate the offset relative to the loop variable.
4128 First multiply by the stride. */
4129 tmp = loop->from[n];
4130 if (!integer_onep (info->stride[dim]))
4131 tmp = fold_build2_loc (input_location, MULT_EXPR,
4132 gfc_array_index_type,
4133 tmp, info->stride[dim]);
4135 /* Then subtract this from our starting value. */
4136 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4137 gfc_array_index_type,
4138 info->start[dim], tmp);
4140 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4147 /* Calculate the size of a given array dimension from the bounds. This
4148 is simply (ubound - lbound + 1) if this expression is positive
4149 or 0 if it is negative (pick either one if it is zero). Optionally
4150 (if or_expr is present) OR the (expression != 0) condition to it. */
4153 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4158 /* Calculate (ubound - lbound + 1). */
4159 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4161 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4162 gfc_index_one_node);
4164 /* Check whether the size for this dimension is negative. */
4165 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4166 gfc_index_zero_node);
4167 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4168 gfc_index_zero_node, res);
4170 /* Build OR expression. */
4172 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4173 boolean_type_node, *or_expr, cond);
4179 /* For an array descriptor, get the total number of elements. This is just
4180 the product of the extents along from_dim to to_dim. */
4183 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4188 res = gfc_index_one_node;
4190 for (dim = from_dim; dim < to_dim; ++dim)
4196 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4197 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4199 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4200 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4208 /* Full size of an array. */
4211 gfc_conv_descriptor_size (tree desc, int rank)
4213 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4217 /* Size of a coarray for all dimensions but the last. */
4220 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4222 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4226 /* Fills in an array descriptor, and returns the size of the array.
4227 The size will be a simple_val, ie a variable or a constant. Also
4228 calculates the offset of the base. The pointer argument overflow,
4229 which should be of integer type, will increase in value if overflow
4230 occurs during the size calculation. Returns the size of the array.
4234 for (n = 0; n < rank; n++)
4236 a.lbound[n] = specified_lower_bound;
4237 offset = offset + a.lbond[n] * stride;
4239 a.ubound[n] = specified_upper_bound;
4240 a.stride[n] = stride;
4241 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4242 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4243 stride = stride * size;
4245 for (n = rank; n < rank+corank; n++)
4246 (Set lcobound/ucobound as above.)
4247 element_size = sizeof (array element);
4250 stride = (size_t) stride;
4251 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4252 stride = stride * element_size;
4258 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4259 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4260 stmtblock_t * descriptor_block, tree * overflow)
4273 stmtblock_t thenblock;
4274 stmtblock_t elseblock;
4279 type = TREE_TYPE (descriptor);
4281 stride = gfc_index_one_node;
4282 offset = gfc_index_zero_node;
4284 /* Set the dtype. */
4285 tmp = gfc_conv_descriptor_dtype (descriptor);
4286 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4288 or_expr = boolean_false_node;
4290 for (n = 0; n < rank; n++)
4295 /* We have 3 possibilities for determining the size of the array:
4296 lower == NULL => lbound = 1, ubound = upper[n]
4297 upper[n] = NULL => lbound = 1, ubound = lower[n]
4298 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4301 /* Set lower bound. */
4302 gfc_init_se (&se, NULL);
4304 se.expr = gfc_index_one_node;
4307 gcc_assert (lower[n]);
4310 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4311 gfc_add_block_to_block (pblock, &se.pre);
4315 se.expr = gfc_index_one_node;
4319 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4320 gfc_rank_cst[n], se.expr);
4321 conv_lbound = se.expr;
4323 /* Work out the offset for this component. */
4324 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4326 offset = fold_build2_loc (input_location, MINUS_EXPR,
4327 gfc_array_index_type, offset, tmp);
4329 /* Set upper bound. */
4330 gfc_init_se (&se, NULL);
4331 gcc_assert (ubound);
4332 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4333 gfc_add_block_to_block (pblock, &se.pre);
4335 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4336 gfc_rank_cst[n], se.expr);
4337 conv_ubound = se.expr;
4339 /* Store the stride. */
4340 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4341 gfc_rank_cst[n], stride);
4343 /* Calculate size and check whether extent is negative. */
4344 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4345 size = gfc_evaluate_now (size, pblock);
4347 /* Check whether multiplying the stride by the number of
4348 elements in this dimension would overflow. We must also check
4349 whether the current dimension has zero size in order to avoid
4352 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4353 gfc_array_index_type,
4354 fold_convert (gfc_array_index_type,
4355 TYPE_MAX_VALUE (gfc_array_index_type)),
4357 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4358 boolean_type_node, tmp, stride));
4359 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4360 integer_one_node, integer_zero_node);
4361 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4362 boolean_type_node, size,
4363 gfc_index_zero_node));
4364 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4365 integer_zero_node, tmp);
4366 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4368 *overflow = gfc_evaluate_now (tmp, pblock);
4370 /* Multiply the stride by the number of elements in this dimension. */
4371 stride = fold_build2_loc (input_location, MULT_EXPR,
4372 gfc_array_index_type, stride, size);
4373 stride = gfc_evaluate_now (stride, pblock);
4376 for (n = rank; n < rank + corank; n++)
4380 /* Set lower bound. */
4381 gfc_init_se (&se, NULL);
4382 if (lower == NULL || lower[n] == NULL)
4384 gcc_assert (n == rank + corank - 1);
4385 se.expr = gfc_index_one_node;
4389 if (ubound || n == rank + corank - 1)
4391 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4392 gfc_add_block_to_block (pblock, &se.pre);
4396 se.expr = gfc_index_one_node;
4400 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4401 gfc_rank_cst[n], se.expr);
4403 if (n < rank + corank - 1)
4405 gfc_init_se (&se, NULL);
4406 gcc_assert (ubound);
4407 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4408 gfc_add_block_to_block (pblock, &se.pre);
4409 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4410 gfc_rank_cst[n], se.expr);
4414 /* The stride is the number of elements in the array, so multiply by the
4415 size of an element to get the total size. */
4416 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4417 /* Convert to size_t. */
4418 element_size = fold_convert (size_type_node, tmp);
4421 return element_size;
4423 stride = fold_convert (size_type_node, stride);
4425 /* First check for overflow. Since an array of type character can
4426 have zero element_size, we must check for that before
4428 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4430 TYPE_MAX_VALUE (size_type_node), element_size);
4431 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4432 boolean_type_node, tmp, stride));
4433 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4434 integer_one_node, integer_zero_node);
4435 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4436 boolean_type_node, element_size,
4437 build_int_cst (size_type_node, 0)));
4438 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4439 integer_zero_node, tmp);
4440 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4442 *overflow = gfc_evaluate_now (tmp, pblock);
4444 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4445 stride, element_size);
4447 if (poffset != NULL)
4449 offset = gfc_evaluate_now (offset, pblock);
4453 if (integer_zerop (or_expr))
4455 if (integer_onep (or_expr))
4456 return build_int_cst (size_type_node, 0);
4458 var = gfc_create_var (TREE_TYPE (size), "size");
4459 gfc_start_block (&thenblock);
4460 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4461 thencase = gfc_finish_block (&thenblock);
4463 gfc_start_block (&elseblock);
4464 gfc_add_modify (&elseblock, var, size);
4465 elsecase = gfc_finish_block (&elseblock);
4467 tmp = gfc_evaluate_now (or_expr, pblock);
4468 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4469 gfc_add_expr_to_block (pblock, tmp);
4475 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4476 the work for an ALLOCATE statement. */
4480 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4485 tree offset = NULL_TREE;
4486 tree token = NULL_TREE;
4489 tree error = NULL_TREE;
4490 tree overflow; /* Boolean storing whether size calculation overflows. */
4491 tree var_overflow = NULL_TREE;
4493 tree set_descriptor;
4494 stmtblock_t set_descriptor_block;
4495 stmtblock_t elseblock;
4498 gfc_ref *ref, *prev_ref = NULL;
4499 bool allocatable, coarray, dimension;
4503 /* Find the last reference in the chain. */
4504 while (ref && ref->next != NULL)
4506 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4507 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4512 if (ref == NULL || ref->type != REF_ARRAY)
4517 allocatable = expr->symtree->n.sym->attr.allocatable;
4518 coarray = expr->symtree->n.sym->attr.codimension;
4519 dimension = expr->symtree->n.sym->attr.dimension;
4523 allocatable = prev_ref->u.c.component->attr.allocatable;
4524 coarray = prev_ref->u.c.component->attr.codimension;
4525 dimension = prev_ref->u.c.component->attr.dimension;
4529 gcc_assert (coarray);
4531 /* Figure out the size of the array. */
4532 switch (ref->u.ar.type)
4538 upper = ref->u.ar.start;
4544 lower = ref->u.ar.start;
4545 upper = ref->u.ar.end;
4549 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4551 lower = ref->u.ar.as->lower;
4552 upper = ref->u.ar.as->upper;
4560 overflow = integer_zero_node;
4562 gfc_init_block (&set_descriptor_block);
4563 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4564 ref->u.ar.as->corank, &offset, lower, upper,
4565 &se->pre, &set_descriptor_block, &overflow);
4570 var_overflow = gfc_create_var (integer_type_node, "overflow");
4571 gfc_add_modify (&se->pre, var_overflow, overflow);
4573 /* Generate the block of code handling overflow. */
4574 msg = gfc_build_addr_expr (pchar_type_node,
4575 gfc_build_localized_cstring_const
4576 ("Integer overflow when calculating the amount of "
4577 "memory to allocate"));
4578 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4582 if (status != NULL_TREE)
4584 tree status_type = TREE_TYPE (status);
4585 stmtblock_t set_status_block;
4587 gfc_start_block (&set_status_block);
4588 gfc_add_modify (&set_status_block, status,
4589 build_int_cst (status_type, LIBERROR_ALLOCATION));
4590 error = gfc_finish_block (&set_status_block);
4593 gfc_start_block (&elseblock);
4595 /* Allocate memory to store the data. */
4596 pointer = gfc_conv_descriptor_data_get (se->expr);
4597 STRIP_NOPS (pointer);
4599 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4600 token = gfc_build_addr_expr (NULL_TREE,
4601 gfc_conv_descriptor_token (se->expr));
4603 /* The allocatable variant takes the old pointer as first argument. */
4605 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4606 status, errmsg, errlen, expr);
4608 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4612 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4613 boolean_type_node, var_overflow, integer_zero_node));
4614 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4615 error, gfc_finish_block (&elseblock));
4618 tmp = gfc_finish_block (&elseblock);
4620 gfc_add_expr_to_block (&se->pre, tmp);
4622 /* Update the array descriptors. */
4624 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4626 set_descriptor = gfc_finish_block (&set_descriptor_block);
4627 if (status != NULL_TREE)
4629 cond = fold_build2_loc (input_location, EQ_EXPR,
4630 boolean_type_node, status,
4631 build_int_cst (TREE_TYPE (status), 0));
4632 gfc_add_expr_to_block (&se->pre,
4633 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4634 gfc_likely (cond), set_descriptor,
4635 build_empty_stmt (input_location)));
4638 gfc_add_expr_to_block (&se->pre, set_descriptor);
4640 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4641 && expr->ts.u.derived->attr.alloc_comp)
4643 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4644 ref->u.ar.as->rank);
4645 gfc_add_expr_to_block (&se->pre, tmp);
4652 /* Deallocate an array variable. Also used when an allocated variable goes
4657 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4663 gfc_start_block (&block);
4664 /* Get a pointer to the data. */
4665 var = gfc_conv_descriptor_data_get (descriptor);
4668 /* Parameter is the address of the data component. */
4669 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4670 gfc_add_expr_to_block (&block, tmp);
4672 /* Zero the data pointer. */
4673 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4674 var, build_int_cst (TREE_TYPE (var), 0));
4675 gfc_add_expr_to_block (&block, tmp);
4677 return gfc_finish_block (&block);
4681 /* Create an array constructor from an initialization expression.
4682 We assume the frontend already did any expansions and conversions. */
4685 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4691 unsigned HOST_WIDE_INT lo;
4693 VEC(constructor_elt,gc) *v = NULL;
4695 switch (expr->expr_type)
4698 case EXPR_STRUCTURE:
4699 /* A single scalar or derived type value. Create an array with all
4700 elements equal to that value. */
4701 gfc_init_se (&se, NULL);
4703 if (expr->expr_type == EXPR_CONSTANT)
4704 gfc_conv_constant (&se, expr);
4706 gfc_conv_structure (&se, expr, 1);
4708 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4709 gcc_assert (tmp && INTEGER_CST_P (tmp));
4710 hi = TREE_INT_CST_HIGH (tmp);
4711 lo = TREE_INT_CST_LOW (tmp);
4715 /* This will probably eat buckets of memory for large arrays. */
4716 while (hi != 0 || lo != 0)
4718 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4726 /* Create a vector of all the elements. */
4727 for (c = gfc_constructor_first (expr->value.constructor);
4728 c; c = gfc_constructor_next (c))
4732 /* Problems occur when we get something like
4733 integer :: a(lots) = (/(i, i=1, lots)/) */
4734 gfc_fatal_error ("The number of elements in the array constructor "
4735 "at %L requires an increase of the allowed %d "
4736 "upper limit. See -fmax-array-constructor "
4737 "option", &expr->where,
4738 gfc_option.flag_max_array_constructor);
4741 if (mpz_cmp_si (c->offset, 0) != 0)
4742 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4746 if (mpz_cmp_si (c->repeat, 1) > 0)
4752 mpz_add (maxval, c->offset, c->repeat);
4753 mpz_sub_ui (maxval, maxval, 1);
4754 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4755 if (mpz_cmp_si (c->offset, 0) != 0)
4757 mpz_add_ui (maxval, c->offset, 1);
4758 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4761 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4763 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4769 gfc_init_se (&se, NULL);
4770 switch (c->expr->expr_type)
4773 gfc_conv_constant (&se, c->expr);
4776 case EXPR_STRUCTURE:
4777 gfc_conv_structure (&se, c->expr, 1);
4781 /* Catch those occasional beasts that do not simplify
4782 for one reason or another, assuming that if they are
4783 standard defying the frontend will catch them. */
4784 gfc_conv_expr (&se, c->expr);
4788 if (range == NULL_TREE)
4789 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4792 if (index != NULL_TREE)
4793 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4794 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4800 return gfc_build_null_descriptor (type);
4806 /* Create a constructor from the list of elements. */
4807 tmp = build_constructor (type, v);
4808 TREE_CONSTANT (tmp) = 1;
4813 /* Generate code to evaluate non-constant coarray cobounds. */
4816 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4817 const gfc_symbol *sym)
4827 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4829 /* Evaluate non-constant array bound expressions. */
4830 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4831 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4833 gfc_init_se (&se, NULL);
4834 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4835 gfc_add_block_to_block (pblock, &se.pre);
4836 gfc_add_modify (pblock, lbound, se.expr);
4838 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4839 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4841 gfc_init_se (&se, NULL);
4842 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4843 gfc_add_block_to_block (pblock, &se.pre);
4844 gfc_add_modify (pblock, ubound, se.expr);
4850 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4851 returns the size (in elements) of the array. */
4854 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4855 stmtblock_t * pblock)
4870 size = gfc_index_one_node;
4871 offset = gfc_index_zero_node;
4872 for (dim = 0; dim < as->rank; dim++)
4874 /* Evaluate non-constant array bound expressions. */
4875 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4876 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4878 gfc_init_se (&se, NULL);
4879 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4880 gfc_add_block_to_block (pblock, &se.pre);
4881 gfc_add_modify (pblock, lbound, se.expr);
4883 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4884 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4886 gfc_init_se (&se, NULL);
4887 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4888 gfc_add_block_to_block (pblock, &se.pre);
4889 gfc_add_modify (pblock, ubound, se.expr);
4891 /* The offset of this dimension. offset = offset - lbound * stride. */
4892 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4894 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4897 /* The size of this dimension, and the stride of the next. */
4898 if (dim + 1 < as->rank)
4899 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4901 stride = GFC_TYPE_ARRAY_SIZE (type);
4903 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4905 /* Calculate stride = size * (ubound + 1 - lbound). */
4906 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4907 gfc_array_index_type,
4908 gfc_index_one_node, lbound);
4909 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4910 gfc_array_index_type, ubound, tmp);
4911 tmp = fold_build2_loc (input_location, MULT_EXPR,
4912 gfc_array_index_type, size, tmp);
4914 gfc_add_modify (pblock, stride, tmp);
4916 stride = gfc_evaluate_now (tmp, pblock);
4918 /* Make sure that negative size arrays are translated
4919 to being zero size. */
4920 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4921 stride, gfc_index_zero_node);
4922 tmp = fold_build3_loc (input_location, COND_EXPR,
4923 gfc_array_index_type, tmp,
4924 stride, gfc_index_zero_node);
4925 gfc_add_modify (pblock, stride, tmp);
4931 gfc_trans_array_cobounds (type, pblock, sym);
4932 gfc_trans_vla_type_sizes (sym, pblock);
4939 /* Generate code to initialize/allocate an array variable. */
4942 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4943 gfc_wrapped_block * block)
4947 tree tmp = NULL_TREE;
4954 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4956 /* Do nothing for USEd variables. */
4957 if (sym->attr.use_assoc)
4960 type = TREE_TYPE (decl);
4961 gcc_assert (GFC_ARRAY_TYPE_P (type));
4962 onstack = TREE_CODE (type) != POINTER_TYPE;
4964 gfc_init_block (&init);
4966 /* Evaluate character string length. */
4967 if (sym->ts.type == BT_CHARACTER
4968 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4970 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4972 gfc_trans_vla_type_sizes (sym, &init);
4974 /* Emit a DECL_EXPR for this variable, which will cause the
4975 gimplifier to allocate storage, and all that good stuff. */
4976 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4977 gfc_add_expr_to_block (&init, tmp);
4982 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4986 type = TREE_TYPE (type);
4988 gcc_assert (!sym->attr.use_assoc);
4989 gcc_assert (!TREE_STATIC (decl));
4990 gcc_assert (!sym->module);
4992 if (sym->ts.type == BT_CHARACTER
4993 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4994 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4996 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4998 /* Don't actually allocate space for Cray Pointees. */
4999 if (sym->attr.cray_pointee)
5001 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5002 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5004 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5008 if (gfc_option.flag_stack_arrays)
5010 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5011 space = build_decl (sym->declared_at.lb->location,
5012 VAR_DECL, create_tmp_var_name ("A"),
5013 TREE_TYPE (TREE_TYPE (decl)));
5014 gfc_trans_vla_type_sizes (sym, &init);
5018 /* The size is the number of elements in the array, so multiply by the
5019 size of an element to get the total size. */
5020 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5021 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5022 size, fold_convert (gfc_array_index_type, tmp));
5024 /* Allocate memory to hold the data. */
5025 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5026 gfc_add_modify (&init, decl, tmp);
5028 /* Free the temporary. */
5029 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5033 /* Set offset of the array. */
5034 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5035 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5037 /* Automatic arrays should not have initializers. */
5038 gcc_assert (!sym->value);
5040 inittree = gfc_finish_block (&init);
5047 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5048 where also space is located. */
5049 gfc_init_block (&init);
5050 tmp = fold_build1_loc (input_location, DECL_EXPR,
5051 TREE_TYPE (space), space);
5052 gfc_add_expr_to_block (&init, tmp);
5053 addr = fold_build1_loc (sym->declared_at.lb->location,
5054 ADDR_EXPR, TREE_TYPE (decl), space);
5055 gfc_add_modify (&init, decl, addr);
5056 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5059 gfc_add_init_cleanup (block, inittree, tmp);
5063 /* Generate entry and exit code for g77 calling convention arrays. */
5066 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5076 gfc_save_backend_locus (&loc);
5077 gfc_set_backend_locus (&sym->declared_at);
5079 /* Descriptor type. */
5080 parm = sym->backend_decl;
5081 type = TREE_TYPE (parm);
5082 gcc_assert (GFC_ARRAY_TYPE_P (type));
5084 gfc_start_block (&init);
5086 if (sym->ts.type == BT_CHARACTER
5087 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5088 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5090 /* Evaluate the bounds of the array. */
5091 gfc_trans_array_bounds (type, sym, &offset, &init);
5093 /* Set the offset. */
5094 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5095 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5097 /* Set the pointer itself if we aren't using the parameter directly. */
5098 if (TREE_CODE (parm) != PARM_DECL)
5100 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5101 gfc_add_modify (&init, parm, tmp);
5103 stmt = gfc_finish_block (&init);
5105 gfc_restore_backend_locus (&loc);
5107 /* Add the initialization code to the start of the function. */
5109 if (sym->attr.optional || sym->attr.not_always_present)
5111 tmp = gfc_conv_expr_present (sym);
5112 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5115 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5119 /* Modify the descriptor of an array parameter so that it has the
5120 correct lower bound. Also move the upper bound accordingly.
5121 If the array is not packed, it will be copied into a temporary.
5122 For each dimension we set the new lower and upper bounds. Then we copy the
5123 stride and calculate the offset for this dimension. We also work out
5124 what the stride of a packed array would be, and see it the two match.
5125 If the array need repacking, we set the stride to the values we just
5126 calculated, recalculate the offset and copy the array data.
5127 Code is also added to copy the data back at the end of the function.
5131 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5132 gfc_wrapped_block * block)
5139 tree stmtInit, stmtCleanup;
5146 tree stride, stride2;
5156 /* Do nothing for pointer and allocatable arrays. */
5157 if (sym->attr.pointer || sym->attr.allocatable)
5160 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5162 gfc_trans_g77_array (sym, block);
5166 gfc_save_backend_locus (&loc);
5167 gfc_set_backend_locus (&sym->declared_at);
5169 /* Descriptor type. */
5170 type = TREE_TYPE (tmpdesc);
5171 gcc_assert (GFC_ARRAY_TYPE_P (type));
5172 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5173 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5174 gfc_start_block (&init);
5176 if (sym->ts.type == BT_CHARACTER
5177 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5178 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5180 checkparm = (sym->as->type == AS_EXPLICIT
5181 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5183 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5184 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5186 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5188 /* For non-constant shape arrays we only check if the first dimension
5189 is contiguous. Repacking higher dimensions wouldn't gain us
5190 anything as we still don't know the array stride. */
5191 partial = gfc_create_var (boolean_type_node, "partial");
5192 TREE_USED (partial) = 1;
5193 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5194 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5195 gfc_index_one_node);
5196 gfc_add_modify (&init, partial, tmp);
5199 partial = NULL_TREE;
5201 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5202 here, however I think it does the right thing. */
5205 /* Set the first stride. */
5206 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5207 stride = gfc_evaluate_now (stride, &init);
5209 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5210 stride, gfc_index_zero_node);
5211 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5212 tmp, gfc_index_one_node, stride);
5213 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5214 gfc_add_modify (&init, stride, tmp);
5216 /* Allow the user to disable array repacking. */
5217 stmt_unpacked = NULL_TREE;
5221 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5222 /* A library call to repack the array if necessary. */
5223 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5224 stmt_unpacked = build_call_expr_loc (input_location,
5225 gfor_fndecl_in_pack, 1, tmp);
5227 stride = gfc_index_one_node;
5229 if (gfc_option.warn_array_temp)
5230 gfc_warning ("Creating array temporary at %L", &loc);
5233 /* This is for the case where the array data is used directly without
5234 calling the repack function. */
5235 if (no_repack || partial != NULL_TREE)
5236 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5238 stmt_packed = NULL_TREE;
5240 /* Assign the data pointer. */
5241 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5243 /* Don't repack unknown shape arrays when the first stride is 1. */
5244 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5245 partial, stmt_packed, stmt_unpacked);
5248 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5249 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5251 offset = gfc_index_zero_node;
5252 size = gfc_index_one_node;
5254 /* Evaluate the bounds of the array. */
5255 for (n = 0; n < sym->as->rank; n++)
5257 if (checkparm || !sym->as->upper[n])
5259 /* Get the bounds of the actual parameter. */
5260 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5261 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5265 dubound = NULL_TREE;
5266 dlbound = NULL_TREE;
5269 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5270 if (!INTEGER_CST_P (lbound))
5272 gfc_init_se (&se, NULL);
5273 gfc_conv_expr_type (&se, sym->as->lower[n],
5274 gfc_array_index_type);
5275 gfc_add_block_to_block (&init, &se.pre);
5276 gfc_add_modify (&init, lbound, se.expr);
5279 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5280 /* Set the desired upper bound. */
5281 if (sym->as->upper[n])
5283 /* We know what we want the upper bound to be. */
5284 if (!INTEGER_CST_P (ubound))
5286 gfc_init_se (&se, NULL);
5287 gfc_conv_expr_type (&se, sym->as->upper[n],
5288 gfc_array_index_type);
5289 gfc_add_block_to_block (&init, &se.pre);
5290 gfc_add_modify (&init, ubound, se.expr);
5293 /* Check the sizes match. */
5296 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5300 temp = fold_build2_loc (input_location, MINUS_EXPR,
5301 gfc_array_index_type, ubound, lbound);
5302 temp = fold_build2_loc (input_location, PLUS_EXPR,
5303 gfc_array_index_type,
5304 gfc_index_one_node, temp);
5305 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5306 gfc_array_index_type, dubound,
5308 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5309 gfc_array_index_type,
5310 gfc_index_one_node, stride2);
5311 tmp = fold_build2_loc (input_location, NE_EXPR,
5312 gfc_array_index_type, temp, stride2);
5313 asprintf (&msg, "Dimension %d of array '%s' has extent "
5314 "%%ld instead of %%ld", n+1, sym->name);
5316 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5317 fold_convert (long_integer_type_node, temp),
5318 fold_convert (long_integer_type_node, stride2));
5325 /* For assumed shape arrays move the upper bound by the same amount
5326 as the lower bound. */
5327 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5328 gfc_array_index_type, dubound, dlbound);
5329 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5330 gfc_array_index_type, tmp, lbound);
5331 gfc_add_modify (&init, ubound, tmp);
5333 /* The offset of this dimension. offset = offset - lbound * stride. */
5334 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5336 offset = fold_build2_loc (input_location, MINUS_EXPR,
5337 gfc_array_index_type, offset, tmp);
5339 /* The size of this dimension, and the stride of the next. */
5340 if (n + 1 < sym->as->rank)
5342 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5344 if (no_repack || partial != NULL_TREE)
5346 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5348 /* Figure out the stride if not a known constant. */
5349 if (!INTEGER_CST_P (stride))
5352 stmt_packed = NULL_TREE;
5355 /* Calculate stride = size * (ubound + 1 - lbound). */
5356 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5357 gfc_array_index_type,
5358 gfc_index_one_node, lbound);
5359 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5360 gfc_array_index_type, ubound, tmp);
5361 size = fold_build2_loc (input_location, MULT_EXPR,
5362 gfc_array_index_type, size, tmp);
5366 /* Assign the stride. */
5367 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5368 tmp = fold_build3_loc (input_location, COND_EXPR,
5369 gfc_array_index_type, partial,
5370 stmt_unpacked, stmt_packed);
5372 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5373 gfc_add_modify (&init, stride, tmp);
5378 stride = GFC_TYPE_ARRAY_SIZE (type);
5380 if (stride && !INTEGER_CST_P (stride))
5382 /* Calculate size = stride * (ubound + 1 - lbound). */
5383 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5384 gfc_array_index_type,
5385 gfc_index_one_node, lbound);
5386 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5387 gfc_array_index_type,
5389 tmp = fold_build2_loc (input_location, MULT_EXPR,
5390 gfc_array_index_type,
5391 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5392 gfc_add_modify (&init, stride, tmp);
5397 gfc_trans_array_cobounds (type, &init, sym);
5399 /* Set the offset. */
5400 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5401 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5403 gfc_trans_vla_type_sizes (sym, &init);
5405 stmtInit = gfc_finish_block (&init);
5407 /* Only do the entry/initialization code if the arg is present. */
5408 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5409 optional_arg = (sym->attr.optional
5410 || (sym->ns->proc_name->attr.entry_master
5411 && sym->attr.dummy));
5414 tmp = gfc_conv_expr_present (sym);
5415 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5416 build_empty_stmt (input_location));
5421 stmtCleanup = NULL_TREE;
5424 stmtblock_t cleanup;
5425 gfc_start_block (&cleanup);
5427 if (sym->attr.intent != INTENT_IN)
5429 /* Copy the data back. */
5430 tmp = build_call_expr_loc (input_location,
5431 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5432 gfc_add_expr_to_block (&cleanup, tmp);
5435 /* Free the temporary. */
5436 tmp = gfc_call_free (tmpdesc);
5437 gfc_add_expr_to_block (&cleanup, tmp);
5439 stmtCleanup = gfc_finish_block (&cleanup);
5441 /* Only do the cleanup if the array was repacked. */
5442 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5443 tmp = gfc_conv_descriptor_data_get (tmp);
5444 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5446 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5447 build_empty_stmt (input_location));
5451 tmp = gfc_conv_expr_present (sym);
5452 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5453 build_empty_stmt (input_location));
5457 /* We don't need to free any memory allocated by internal_pack as it will
5458 be freed at the end of the function by pop_context. */
5459 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5461 gfc_restore_backend_locus (&loc);
5465 /* Calculate the overall offset, including subreferences. */
5467 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5468 bool subref, gfc_expr *expr)
5478 /* If offset is NULL and this is not a subreferenced array, there is
5480 if (offset == NULL_TREE)
5483 offset = gfc_index_zero_node;
5488 tmp = gfc_conv_array_data (desc);
5489 tmp = build_fold_indirect_ref_loc (input_location,
5491 tmp = gfc_build_array_ref (tmp, offset, NULL);
5493 /* Offset the data pointer for pointer assignments from arrays with
5494 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5497 /* Go past the array reference. */
5498 for (ref = expr->ref; ref; ref = ref->next)
5499 if (ref->type == REF_ARRAY &&
5500 ref->u.ar.type != AR_ELEMENT)
5506 /* Calculate the offset for each subsequent subreference. */
5507 for (; ref; ref = ref->next)
5512 field = ref->u.c.component->backend_decl;
5513 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5514 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5516 tmp, field, NULL_TREE);
5520 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5521 gfc_init_se (&start, NULL);
5522 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5523 gfc_add_block_to_block (block, &start.pre);
5524 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5528 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5529 && ref->u.ar.type == AR_ELEMENT);
5531 /* TODO - Add bounds checking. */
5532 stride = gfc_index_one_node;
5533 index = gfc_index_zero_node;
5534 for (n = 0; n < ref->u.ar.dimen; n++)
5539 /* Update the index. */
5540 gfc_init_se (&start, NULL);
5541 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5542 itmp = gfc_evaluate_now (start.expr, block);
5543 gfc_init_se (&start, NULL);
5544 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5545 jtmp = gfc_evaluate_now (start.expr, block);
5546 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5547 gfc_array_index_type, itmp, jtmp);
5548 itmp = fold_build2_loc (input_location, MULT_EXPR,
5549 gfc_array_index_type, itmp, stride);
5550 index = fold_build2_loc (input_location, PLUS_EXPR,
5551 gfc_array_index_type, itmp, index);
5552 index = gfc_evaluate_now (index, block);
5554 /* Update the stride. */
5555 gfc_init_se (&start, NULL);
5556 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5557 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5558 gfc_array_index_type, start.expr,
5560 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5561 gfc_array_index_type,
5562 gfc_index_one_node, itmp);
5563 stride = fold_build2_loc (input_location, MULT_EXPR,
5564 gfc_array_index_type, stride, itmp);
5565 stride = gfc_evaluate_now (stride, block);
5568 /* Apply the index to obtain the array element. */
5569 tmp = gfc_build_array_ref (tmp, index, NULL);
5579 /* Set the target data pointer. */
5580 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5581 gfc_conv_descriptor_data_set (block, parm, offset);
5585 /* gfc_conv_expr_descriptor needs the string length an expression
5586 so that the size of the temporary can be obtained. This is done
5587 by adding up the string lengths of all the elements in the
5588 expression. Function with non-constant expressions have their
5589 string lengths mapped onto the actual arguments using the
5590 interface mapping machinery in trans-expr.c. */
5592 get_array_charlen (gfc_expr *expr, gfc_se *se)
5594 gfc_interface_mapping mapping;
5595 gfc_formal_arglist *formal;
5596 gfc_actual_arglist *arg;
5599 if (expr->ts.u.cl->length
5600 && gfc_is_constant_expr (expr->ts.u.cl->length))
5602 if (!expr->ts.u.cl->backend_decl)
5603 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5607 switch (expr->expr_type)
5610 get_array_charlen (expr->value.op.op1, se);
5612 /* For parentheses the expression ts.u.cl is identical. */
5613 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5616 expr->ts.u.cl->backend_decl =
5617 gfc_create_var (gfc_charlen_type_node, "sln");
5619 if (expr->value.op.op2)
5621 get_array_charlen (expr->value.op.op2, se);
5623 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5625 /* Add the string lengths and assign them to the expression
5626 string length backend declaration. */
5627 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5628 fold_build2_loc (input_location, PLUS_EXPR,
5629 gfc_charlen_type_node,
5630 expr->value.op.op1->ts.u.cl->backend_decl,
5631 expr->value.op.op2->ts.u.cl->backend_decl));
5634 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5635 expr->value.op.op1->ts.u.cl->backend_decl);
5639 if (expr->value.function.esym == NULL
5640 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5642 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5646 /* Map expressions involving the dummy arguments onto the actual
5647 argument expressions. */
5648 gfc_init_interface_mapping (&mapping);
5649 formal = expr->symtree->n.sym->formal;
5650 arg = expr->value.function.actual;
5652 /* Set se = NULL in the calls to the interface mapping, to suppress any
5654 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5659 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5662 gfc_init_se (&tse, NULL);
5664 /* Build the expression for the character length and convert it. */
5665 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5667 gfc_add_block_to_block (&se->pre, &tse.pre);
5668 gfc_add_block_to_block (&se->post, &tse.post);
5669 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5670 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5671 gfc_charlen_type_node, tse.expr,
5672 build_int_cst (gfc_charlen_type_node, 0));
5673 expr->ts.u.cl->backend_decl = tse.expr;
5674 gfc_free_interface_mapping (&mapping);
5678 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5683 /* Helper function to check dimensions. */
5685 dim_ok (gfc_ss_info *info)
5688 for (n = 0; n < info->dimen; n++)
5689 if (info->dim[n] != n)
5694 /* Convert an array for passing as an actual argument. Expressions and
5695 vector subscripts are evaluated and stored in a temporary, which is then
5696 passed. For whole arrays the descriptor is passed. For array sections
5697 a modified copy of the descriptor is passed, but using the original data.
5699 This function is also used for array pointer assignments, and there
5702 - se->want_pointer && !se->direct_byref
5703 EXPR is an actual argument. On exit, se->expr contains a
5704 pointer to the array descriptor.
5706 - !se->want_pointer && !se->direct_byref
5707 EXPR is an actual argument to an intrinsic function or the
5708 left-hand side of a pointer assignment. On exit, se->expr
5709 contains the descriptor for EXPR.
5711 - !se->want_pointer && se->direct_byref
5712 EXPR is the right-hand side of a pointer assignment and
5713 se->expr is the descriptor for the previously-evaluated
5714 left-hand side. The function creates an assignment from
5718 The se->force_tmp flag disables the non-copying descriptor optimization
5719 that is used for transpose. It may be used in cases where there is an
5720 alias between the transpose argument and another argument in the same
5724 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5736 bool subref_array_target = false;
5739 gcc_assert (ss != NULL);
5740 gcc_assert (ss != gfc_ss_terminator);
5742 /* Special case things we know we can pass easily. */
5743 switch (expr->expr_type)
5746 /* If we have a linear array section, we can pass it directly.
5747 Otherwise we need to copy it into a temporary. */
5749 gcc_assert (ss->type == GFC_SS_SECTION);
5750 gcc_assert (ss->expr == expr);
5751 info = &ss->data.info;
5753 /* Get the descriptor for the array. */
5754 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5755 desc = info->descriptor;
5757 subref_array_target = se->direct_byref && is_subref_array (expr);
5758 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5759 && !subref_array_target;
5766 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5768 /* Create a new descriptor if the array doesn't have one. */
5771 else if (info->ref->u.ar.type == AR_FULL)
5773 else if (se->direct_byref)
5776 full = gfc_full_array_ref_p (info->ref, NULL);
5778 if (full && dim_ok (info))
5780 if (se->direct_byref && !se->byref_noassign)
5782 /* Copy the descriptor for pointer assignments. */
5783 gfc_add_modify (&se->pre, se->expr, desc);
5785 /* Add any offsets from subreferences. */
5786 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5787 subref_array_target, expr);
5789 else if (se->want_pointer)
5791 /* We pass full arrays directly. This means that pointers and
5792 allocatable arrays should also work. */
5793 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5800 if (expr->ts.type == BT_CHARACTER)
5801 se->string_length = gfc_get_expr_charlen (expr);
5809 /* We don't need to copy data in some cases. */
5810 arg = gfc_get_noncopying_intrinsic_argument (expr);
5813 /* This is a call to transpose... */
5814 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5815 /* ... which has already been handled by the scalarizer, so
5816 that we just need to get its argument's descriptor. */
5817 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5821 /* A transformational function return value will be a temporary
5822 array descriptor. We still need to go through the scalarizer
5823 to create the descriptor. Elemental functions ar handled as
5824 arbitrary expressions, i.e. copy to a temporary. */
5826 if (se->direct_byref)
5828 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5830 /* For pointer assignments pass the descriptor directly. */
5834 gcc_assert (se->ss == ss);
5835 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5836 gfc_conv_expr (se, expr);
5840 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5842 if (ss->expr != expr)
5843 /* Elemental function. */
5844 gcc_assert ((expr->value.function.esym != NULL
5845 && expr->value.function.esym->attr.elemental)
5846 || (expr->value.function.isym != NULL
5847 && expr->value.function.isym->elemental));
5849 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5852 if (expr->ts.type == BT_CHARACTER
5853 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5854 get_array_charlen (expr, se);
5860 /* Transformational function. */
5861 info = &ss->data.info;
5867 /* Constant array constructors don't need a temporary. */
5868 if (ss->type == GFC_SS_CONSTRUCTOR
5869 && expr->ts.type != BT_CHARACTER
5870 && gfc_constant_array_constructor_p (expr->value.constructor))
5873 info = &ss->data.info;
5883 /* Something complicated. Copy it into a temporary. */
5889 /* If we are creating a temporary, we don't need to bother about aliases
5894 gfc_init_loopinfo (&loop);
5896 /* Associate the SS with the loop. */
5897 gfc_add_ss_to_loop (&loop, ss);
5899 /* Tell the scalarizer not to bother creating loop variables, etc. */
5901 loop.array_parameter = 1;
5903 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5904 gcc_assert (!se->direct_byref);
5906 /* Setup the scalarizing loops and bounds. */
5907 gfc_conv_ss_startstride (&loop);
5911 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5912 get_array_charlen (expr, se);
5914 /* Tell the scalarizer to make a temporary. */
5915 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
5916 ((expr->ts.type == BT_CHARACTER)
5917 ? expr->ts.u.cl->backend_decl
5921 se->string_length = loop.temp_ss->string_length;
5922 gcc_assert (loop.temp_ss->data.temp.dimen == loop.dimen);
5923 loop.temp_ss->data.temp.codimen = loop.codimen;
5924 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5927 gfc_conv_loop_setup (&loop, & expr->where);
5931 /* Copy into a temporary and pass that. We don't need to copy the data
5932 back because expressions and vector subscripts must be INTENT_IN. */
5933 /* TODO: Optimize passing function return values. */
5937 /* Start the copying loops. */
5938 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5939 gfc_mark_ss_chain_used (ss, 1);
5940 gfc_start_scalarized_body (&loop, &block);
5942 /* Copy each data element. */
5943 gfc_init_se (&lse, NULL);
5944 gfc_copy_loopinfo_to_se (&lse, &loop);
5945 gfc_init_se (&rse, NULL);
5946 gfc_copy_loopinfo_to_se (&rse, &loop);
5948 lse.ss = loop.temp_ss;
5951 gfc_conv_scalarized_array_ref (&lse, NULL);
5952 if (expr->ts.type == BT_CHARACTER)
5954 gfc_conv_expr (&rse, expr);
5955 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5956 rse.expr = build_fold_indirect_ref_loc (input_location,
5960 gfc_conv_expr_val (&rse, expr);
5962 gfc_add_block_to_block (&block, &rse.pre);
5963 gfc_add_block_to_block (&block, &lse.pre);
5965 lse.string_length = rse.string_length;
5966 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5967 expr->expr_type == EXPR_VARIABLE
5968 || expr->expr_type == EXPR_ARRAY, true);
5969 gfc_add_expr_to_block (&block, tmp);
5971 /* Finish the copying loops. */
5972 gfc_trans_scalarizing_loops (&loop, &block);
5974 desc = loop.temp_ss->data.info.descriptor;
5976 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5978 desc = info->descriptor;
5979 se->string_length = ss->string_length;
5983 /* We pass sections without copying to a temporary. Make a new
5984 descriptor and point it at the section we want. The loop variable
5985 limits will be the limits of the section.
5986 A function may decide to repack the array to speed up access, but
5987 we're not bothered about that here. */
5988 int dim, ndim, codim;
5996 if (se->want_coarray)
5997 codim = gfc_get_corank (expr);
6001 /* Set the string_length for a character array. */
6002 if (expr->ts.type == BT_CHARACTER)
6003 se->string_length = gfc_get_expr_charlen (expr);
6005 desc = info->descriptor;
6006 if (se->direct_byref && !se->byref_noassign)
6008 /* For pointer assignments we fill in the destination. */
6010 parmtype = TREE_TYPE (parm);
6014 /* Otherwise make a new one. */
6015 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6016 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6017 loop.from, loop.to, 0,
6018 GFC_ARRAY_UNKNOWN, false);
6019 parm = gfc_create_var (parmtype, "parm");
6022 offset = gfc_index_zero_node;
6024 /* The following can be somewhat confusing. We have two
6025 descriptors, a new one and the original array.
6026 {parm, parmtype, dim} refer to the new one.
6027 {desc, type, n, loop} refer to the original, which maybe
6028 a descriptorless array.
6029 The bounds of the scalarization are the bounds of the section.
6030 We don't have to worry about numeric overflows when calculating
6031 the offsets because all elements are within the array data. */
6033 /* Set the dtype. */
6034 tmp = gfc_conv_descriptor_dtype (parm);
6035 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6037 /* Set offset for assignments to pointer only to zero if it is not
6039 if (se->direct_byref
6040 && info->ref && info->ref->u.ar.type != AR_FULL)
6041 base = gfc_index_zero_node;
6042 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6043 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6047 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
6048 for (n = 0; n < ndim; n++)
6050 stride = gfc_conv_array_stride (desc, n);
6052 /* Work out the offset. */
6054 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6056 gcc_assert (info->subscript[n]
6057 && info->subscript[n]->type == GFC_SS_SCALAR);
6058 start = info->subscript[n]->data.scalar.expr;
6062 /* Evaluate and remember the start of the section. */
6063 start = info->start[n];
6064 stride = gfc_evaluate_now (stride, &loop.pre);
6067 tmp = gfc_conv_array_lbound (desc, n);
6068 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6070 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6072 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6076 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6078 /* For elemental dimensions, we only need the offset. */
6082 /* Vector subscripts need copying and are handled elsewhere. */
6084 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6086 /* look for the corresponding scalarizer dimension: dim. */
6087 for (dim = 0; dim < ndim; dim++)
6088 if (info->dim[dim] == n)
6091 /* loop exited early: the DIM being looked for has been found. */
6092 gcc_assert (dim < ndim);
6094 /* Set the new lower bound. */
6095 from = loop.from[dim];
6098 /* If we have an array section or are assigning make sure that
6099 the lower bound is 1. References to the full
6100 array should otherwise keep the original bounds. */
6102 || info->ref->u.ar.type != AR_FULL)
6103 && !integer_onep (from))
6105 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6106 gfc_array_index_type, gfc_index_one_node,
6108 to = fold_build2_loc (input_location, PLUS_EXPR,
6109 gfc_array_index_type, to, tmp);
6110 from = gfc_index_one_node;
6112 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6113 gfc_rank_cst[dim], from);
6115 /* Set the new upper bound. */
6116 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6117 gfc_rank_cst[dim], to);
6119 /* Multiply the stride by the section stride to get the
6121 stride = fold_build2_loc (input_location, MULT_EXPR,
6122 gfc_array_index_type,
6123 stride, info->stride[n]);
6125 if (se->direct_byref
6127 && info->ref->u.ar.type != AR_FULL)
6129 base = fold_build2_loc (input_location, MINUS_EXPR,
6130 TREE_TYPE (base), base, stride);
6132 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6134 tmp = gfc_conv_array_lbound (desc, n);
6135 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6136 TREE_TYPE (base), tmp, loop.from[dim]);
6137 tmp = fold_build2_loc (input_location, MULT_EXPR,
6138 TREE_TYPE (base), tmp,
6139 gfc_conv_array_stride (desc, n));
6140 base = fold_build2_loc (input_location, PLUS_EXPR,
6141 TREE_TYPE (base), tmp, base);
6144 /* Store the new stride. */
6145 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6146 gfc_rank_cst[dim], stride);
6149 for (n = ndim; n < ndim + codim; n++)
6151 from = loop.from[n];
6153 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6154 gfc_rank_cst[n], from);
6155 if (n < ndim + codim - 1)
6156 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6157 gfc_rank_cst[n], to);
6160 if (se->data_not_needed)
6161 gfc_conv_descriptor_data_set (&loop.pre, parm,
6162 gfc_index_zero_node);
6164 /* Point the data pointer at the 1st element in the section. */
6165 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6166 subref_array_target, expr);
6168 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6169 && !se->data_not_needed)
6171 /* Set the offset. */
6172 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6176 /* Only the callee knows what the correct offset it, so just set
6178 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6183 if (!se->direct_byref || se->byref_noassign)
6185 /* Get a pointer to the new descriptor. */
6186 if (se->want_pointer)
6187 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6192 gfc_add_block_to_block (&se->pre, &loop.pre);
6193 gfc_add_block_to_block (&se->post, &loop.post);
6195 /* Cleanup the scalarizer. */
6196 gfc_cleanup_loop (&loop);
6199 /* Helper function for gfc_conv_array_parameter if array size needs to be
6203 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6206 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6207 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6208 else if (expr->rank > 1)
6209 *size = build_call_expr_loc (input_location,
6210 gfor_fndecl_size0, 1,
6211 gfc_build_addr_expr (NULL, desc));
6214 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6215 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6217 *size = fold_build2_loc (input_location, MINUS_EXPR,
6218 gfc_array_index_type, ubound, lbound);
6219 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6220 *size, gfc_index_one_node);
6221 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6222 *size, gfc_index_zero_node);
6224 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6225 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6226 *size, fold_convert (gfc_array_index_type, elem));
6229 /* Convert an array for passing as an actual parameter. */
6230 /* TODO: Optimize passing g77 arrays. */
6233 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6234 const gfc_symbol *fsym, const char *proc_name,
6239 tree tmp = NULL_TREE;
6241 tree parent = DECL_CONTEXT (current_function_decl);
6242 bool full_array_var;
6243 bool this_array_result;
6246 bool array_constructor;
6247 bool good_allocatable;
6248 bool ultimate_ptr_comp;
6249 bool ultimate_alloc_comp;
6254 ultimate_ptr_comp = false;
6255 ultimate_alloc_comp = false;
6257 for (ref = expr->ref; ref; ref = ref->next)
6259 if (ref->next == NULL)
6262 if (ref->type == REF_COMPONENT)
6264 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6265 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6269 full_array_var = false;
6272 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6273 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6275 sym = full_array_var ? expr->symtree->n.sym : NULL;
6277 /* The symbol should have an array specification. */
6278 gcc_assert (!sym || sym->as || ref->u.ar.as);
6280 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6282 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6283 expr->ts.u.cl->backend_decl = tmp;
6284 se->string_length = tmp;
6287 /* Is this the result of the enclosing procedure? */
6288 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6289 if (this_array_result
6290 && (sym->backend_decl != current_function_decl)
6291 && (sym->backend_decl != parent))
6292 this_array_result = false;
6294 /* Passing address of the array if it is not pointer or assumed-shape. */
6295 if (full_array_var && g77 && !this_array_result)
6297 tmp = gfc_get_symbol_decl (sym);
6299 if (sym->ts.type == BT_CHARACTER)
6300 se->string_length = sym->ts.u.cl->backend_decl;
6302 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6304 gfc_conv_expr_descriptor (se, expr, ss);
6305 se->expr = gfc_conv_array_data (se->expr);
6309 if (!sym->attr.pointer
6311 && sym->as->type != AS_ASSUMED_SHAPE
6312 && !sym->attr.allocatable)
6314 /* Some variables are declared directly, others are declared as
6315 pointers and allocated on the heap. */
6316 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6319 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6321 array_parameter_size (tmp, expr, size);
6325 if (sym->attr.allocatable)
6327 if (sym->attr.dummy || sym->attr.result)
6329 gfc_conv_expr_descriptor (se, expr, ss);
6333 array_parameter_size (tmp, expr, size);
6334 se->expr = gfc_conv_array_data (tmp);
6339 /* A convenient reduction in scope. */
6340 contiguous = g77 && !this_array_result && contiguous;
6342 /* There is no need to pack and unpack the array, if it is contiguous
6343 and not a deferred- or assumed-shape array, or if it is simply
6345 no_pack = ((sym && sym->as
6346 && !sym->attr.pointer
6347 && sym->as->type != AS_DEFERRED
6348 && sym->as->type != AS_ASSUMED_SHAPE)
6350 (ref && ref->u.ar.as
6351 && ref->u.ar.as->type != AS_DEFERRED
6352 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6354 gfc_is_simply_contiguous (expr, false));
6356 no_pack = contiguous && no_pack;
6358 /* Array constructors are always contiguous and do not need packing. */
6359 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6361 /* Same is true of contiguous sections from allocatable variables. */
6362 good_allocatable = contiguous
6364 && expr->symtree->n.sym->attr.allocatable;
6366 /* Or ultimate allocatable components. */
6367 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6369 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6371 gfc_conv_expr_descriptor (se, expr, ss);
6372 if (expr->ts.type == BT_CHARACTER)
6373 se->string_length = expr->ts.u.cl->backend_decl;
6375 array_parameter_size (se->expr, expr, size);
6376 se->expr = gfc_conv_array_data (se->expr);
6380 if (this_array_result)
6382 /* Result of the enclosing function. */
6383 gfc_conv_expr_descriptor (se, expr, ss);
6385 array_parameter_size (se->expr, expr, size);
6386 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6388 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6389 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6390 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6397 /* Every other type of array. */
6398 se->want_pointer = 1;
6399 gfc_conv_expr_descriptor (se, expr, ss);
6401 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6406 /* Deallocate the allocatable components of structures that are
6408 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6409 && expr->ts.u.derived->attr.alloc_comp
6410 && expr->expr_type != EXPR_VARIABLE)
6412 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6413 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6415 /* The components shall be deallocated before their containing entity. */
6416 gfc_prepend_expr_to_block (&se->post, tmp);
6419 if (g77 || (fsym && fsym->attr.contiguous
6420 && !gfc_is_simply_contiguous (expr, false)))
6422 tree origptr = NULL_TREE;
6426 /* For contiguous arrays, save the original value of the descriptor. */
6429 origptr = gfc_create_var (pvoid_type_node, "origptr");
6430 tmp = build_fold_indirect_ref_loc (input_location, desc);
6431 tmp = gfc_conv_array_data (tmp);
6432 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6433 TREE_TYPE (origptr), origptr,
6434 fold_convert (TREE_TYPE (origptr), tmp));
6435 gfc_add_expr_to_block (&se->pre, tmp);
6438 /* Repack the array. */
6439 if (gfc_option.warn_array_temp)
6442 gfc_warning ("Creating array temporary at %L for argument '%s'",
6443 &expr->where, fsym->name);
6445 gfc_warning ("Creating array temporary at %L", &expr->where);
6448 ptr = build_call_expr_loc (input_location,
6449 gfor_fndecl_in_pack, 1, desc);
6451 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6453 tmp = gfc_conv_expr_present (sym);
6454 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6455 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6456 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6459 ptr = gfc_evaluate_now (ptr, &se->pre);
6461 /* Use the packed data for the actual argument, except for contiguous arrays,
6462 where the descriptor's data component is set. */
6467 tmp = build_fold_indirect_ref_loc (input_location, desc);
6468 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6471 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6475 if (fsym && proc_name)
6476 asprintf (&msg, "An array temporary was created for argument "
6477 "'%s' of procedure '%s'", fsym->name, proc_name);
6479 asprintf (&msg, "An array temporary was created");
6481 tmp = build_fold_indirect_ref_loc (input_location,
6483 tmp = gfc_conv_array_data (tmp);
6484 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6485 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6487 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6488 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6490 gfc_conv_expr_present (sym), tmp);
6492 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6497 gfc_start_block (&block);
6499 /* Copy the data back. */
6500 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6502 tmp = build_call_expr_loc (input_location,
6503 gfor_fndecl_in_unpack, 2, desc, ptr);
6504 gfc_add_expr_to_block (&block, tmp);
6507 /* Free the temporary. */
6508 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6509 gfc_add_expr_to_block (&block, tmp);
6511 stmt = gfc_finish_block (&block);
6513 gfc_init_block (&block);
6514 /* Only if it was repacked. This code needs to be executed before the
6515 loop cleanup code. */
6516 tmp = build_fold_indirect_ref_loc (input_location,
6518 tmp = gfc_conv_array_data (tmp);
6519 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6520 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6522 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6523 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6525 gfc_conv_expr_present (sym), tmp);
6527 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6529 gfc_add_expr_to_block (&block, tmp);
6530 gfc_add_block_to_block (&block, &se->post);
6532 gfc_init_block (&se->post);
6534 /* Reset the descriptor pointer. */
6537 tmp = build_fold_indirect_ref_loc (input_location, desc);
6538 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6541 gfc_add_block_to_block (&se->post, &block);
6546 /* Generate code to deallocate an array, if it is allocated. */
6549 gfc_trans_dealloc_allocated (tree descriptor)
6555 gfc_start_block (&block);
6557 var = gfc_conv_descriptor_data_get (descriptor);
6560 /* Call array_deallocate with an int * present in the second argument.
6561 Although it is ignored here, it's presence ensures that arrays that
6562 are already deallocated are ignored. */
6563 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6564 gfc_add_expr_to_block (&block, tmp);
6566 /* Zero the data pointer. */
6567 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6568 var, build_int_cst (TREE_TYPE (var), 0));
6569 gfc_add_expr_to_block (&block, tmp);
6571 return gfc_finish_block (&block);
6575 /* This helper function calculates the size in words of a full array. */
6578 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6583 idx = gfc_rank_cst[rank - 1];
6584 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6585 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6586 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6588 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6589 tmp, gfc_index_one_node);
6590 tmp = gfc_evaluate_now (tmp, block);
6592 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6593 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6595 return gfc_evaluate_now (tmp, block);
6599 /* Allocate dest to the same size as src, and copy src -> dest.
6600 If no_malloc is set, only the copy is done. */
6603 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6613 /* If the source is null, set the destination to null. Then,
6614 allocate memory to the destination. */
6615 gfc_init_block (&block);
6619 tmp = null_pointer_node;
6620 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6621 gfc_add_expr_to_block (&block, tmp);
6622 null_data = gfc_finish_block (&block);
6624 gfc_init_block (&block);
6625 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6628 tmp = gfc_call_malloc (&block, type, size);
6629 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6630 dest, fold_convert (type, tmp));
6631 gfc_add_expr_to_block (&block, tmp);
6634 tmp = built_in_decls[BUILT_IN_MEMCPY];
6635 tmp = build_call_expr_loc (input_location, tmp, 3,
6640 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6641 null_data = gfc_finish_block (&block);
6643 gfc_init_block (&block);
6644 nelems = get_full_array_size (&block, src, rank);
6645 tmp = fold_convert (gfc_array_index_type,
6646 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6647 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6651 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6652 tmp = gfc_call_malloc (&block, tmp, size);
6653 gfc_conv_descriptor_data_set (&block, dest, tmp);
6656 /* We know the temporary and the value will be the same length,
6657 so can use memcpy. */
6658 tmp = built_in_decls[BUILT_IN_MEMCPY];
6659 tmp = build_call_expr_loc (input_location,
6660 tmp, 3, gfc_conv_descriptor_data_get (dest),
6661 gfc_conv_descriptor_data_get (src), size);
6664 gfc_add_expr_to_block (&block, tmp);
6665 tmp = gfc_finish_block (&block);
6667 /* Null the destination if the source is null; otherwise do
6668 the allocate and copy. */
6672 null_cond = gfc_conv_descriptor_data_get (src);
6674 null_cond = convert (pvoid_type_node, null_cond);
6675 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6676 null_cond, null_pointer_node);
6677 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6681 /* Allocate dest to the same size as src, and copy data src -> dest. */
6684 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6686 return duplicate_allocatable (dest, src, type, rank, false);
6690 /* Copy data src -> dest. */
6693 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6695 return duplicate_allocatable (dest, src, type, rank, true);
6699 /* Recursively traverse an object of derived type, generating code to
6700 deallocate, nullify or copy allocatable components. This is the work horse
6701 function for the functions named in this enum. */
6703 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6704 COPY_ONLY_ALLOC_COMP};
6707 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6708 tree dest, int rank, int purpose)
6712 stmtblock_t fnblock;
6713 stmtblock_t loopbody;
6724 tree null_cond = NULL_TREE;
6726 gfc_init_block (&fnblock);
6728 decl_type = TREE_TYPE (decl);
6730 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6731 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6733 decl = build_fold_indirect_ref_loc (input_location,
6736 /* Just in case in gets dereferenced. */
6737 decl_type = TREE_TYPE (decl);
6739 /* If this an array of derived types with allocatable components
6740 build a loop and recursively call this function. */
6741 if (TREE_CODE (decl_type) == ARRAY_TYPE
6742 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6744 tmp = gfc_conv_array_data (decl);
6745 var = build_fold_indirect_ref_loc (input_location,
6748 /* Get the number of elements - 1 and set the counter. */
6749 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6751 /* Use the descriptor for an allocatable array. Since this
6752 is a full array reference, we only need the descriptor
6753 information from dimension = rank. */
6754 tmp = get_full_array_size (&fnblock, decl, rank);
6755 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6756 gfc_array_index_type, tmp,
6757 gfc_index_one_node);
6759 null_cond = gfc_conv_descriptor_data_get (decl);
6760 null_cond = fold_build2_loc (input_location, NE_EXPR,
6761 boolean_type_node, null_cond,
6762 build_int_cst (TREE_TYPE (null_cond), 0));
6766 /* Otherwise use the TYPE_DOMAIN information. */
6767 tmp = array_type_nelts (decl_type);
6768 tmp = fold_convert (gfc_array_index_type, tmp);
6771 /* Remember that this is, in fact, the no. of elements - 1. */
6772 nelems = gfc_evaluate_now (tmp, &fnblock);
6773 index = gfc_create_var (gfc_array_index_type, "S");
6775 /* Build the body of the loop. */
6776 gfc_init_block (&loopbody);
6778 vref = gfc_build_array_ref (var, index, NULL);
6780 if (purpose == COPY_ALLOC_COMP)
6782 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6784 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6785 gfc_add_expr_to_block (&fnblock, tmp);
6787 tmp = build_fold_indirect_ref_loc (input_location,
6788 gfc_conv_array_data (dest));
6789 dref = gfc_build_array_ref (tmp, index, NULL);
6790 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6792 else if (purpose == COPY_ONLY_ALLOC_COMP)
6794 tmp = build_fold_indirect_ref_loc (input_location,
6795 gfc_conv_array_data (dest));
6796 dref = gfc_build_array_ref (tmp, index, NULL);
6797 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6801 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6803 gfc_add_expr_to_block (&loopbody, tmp);
6805 /* Build the loop and return. */
6806 gfc_init_loopinfo (&loop);
6808 loop.from[0] = gfc_index_zero_node;
6809 loop.loopvar[0] = index;
6810 loop.to[0] = nelems;
6811 gfc_trans_scalarizing_loops (&loop, &loopbody);
6812 gfc_add_block_to_block (&fnblock, &loop.pre);
6814 tmp = gfc_finish_block (&fnblock);
6815 if (null_cond != NULL_TREE)
6816 tmp = build3_v (COND_EXPR, null_cond, tmp,
6817 build_empty_stmt (input_location));
6822 /* Otherwise, act on the components or recursively call self to
6823 act on a chain of components. */
6824 for (c = der_type->components; c; c = c->next)
6826 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6827 || c->ts.type == BT_CLASS)
6828 && c->ts.u.derived->attr.alloc_comp;
6829 cdecl = c->backend_decl;
6830 ctype = TREE_TYPE (cdecl);
6834 case DEALLOCATE_ALLOC_COMP:
6835 if (cmp_has_alloc_comps && !c->attr.pointer)
6837 /* Do not deallocate the components of ultimate pointer
6839 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6840 decl, cdecl, NULL_TREE);
6841 rank = c->as ? c->as->rank : 0;
6842 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6844 gfc_add_expr_to_block (&fnblock, tmp);
6847 if (c->attr.allocatable
6848 && (c->attr.dimension || c->attr.codimension))
6850 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6851 decl, cdecl, NULL_TREE);
6852 tmp = gfc_trans_dealloc_allocated (comp);
6853 gfc_add_expr_to_block (&fnblock, tmp);
6855 else if (c->attr.allocatable)
6857 /* Allocatable scalar components. */
6858 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6859 decl, cdecl, NULL_TREE);
6861 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6863 gfc_add_expr_to_block (&fnblock, tmp);
6865 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6866 void_type_node, comp,
6867 build_int_cst (TREE_TYPE (comp), 0));
6868 gfc_add_expr_to_block (&fnblock, tmp);
6870 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6872 /* Allocatable scalar CLASS components. */
6873 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6874 decl, cdecl, NULL_TREE);
6876 /* Add reference to '_data' component. */
6877 tmp = CLASS_DATA (c)->backend_decl;
6878 comp = fold_build3_loc (input_location, COMPONENT_REF,
6879 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6881 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6882 CLASS_DATA (c)->ts);
6883 gfc_add_expr_to_block (&fnblock, tmp);
6885 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6886 void_type_node, comp,
6887 build_int_cst (TREE_TYPE (comp), 0));
6888 gfc_add_expr_to_block (&fnblock, tmp);
6892 case NULLIFY_ALLOC_COMP:
6893 if (c->attr.pointer)
6895 else if (c->attr.allocatable
6896 && (c->attr.dimension|| c->attr.codimension))
6898 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6899 decl, cdecl, NULL_TREE);
6900 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6902 else if (c->attr.allocatable)
6904 /* Allocatable scalar components. */
6905 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6906 decl, cdecl, NULL_TREE);
6907 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6908 void_type_node, comp,
6909 build_int_cst (TREE_TYPE (comp), 0));
6910 gfc_add_expr_to_block (&fnblock, tmp);
6912 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6914 /* Allocatable scalar CLASS components. */
6915 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6916 decl, cdecl, NULL_TREE);
6917 /* Add reference to '_data' component. */
6918 tmp = CLASS_DATA (c)->backend_decl;
6919 comp = fold_build3_loc (input_location, COMPONENT_REF,
6920 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6921 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6922 void_type_node, comp,
6923 build_int_cst (TREE_TYPE (comp), 0));
6924 gfc_add_expr_to_block (&fnblock, tmp);
6926 else if (cmp_has_alloc_comps)
6928 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6929 decl, cdecl, NULL_TREE);
6930 rank = c->as ? c->as->rank : 0;
6931 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6933 gfc_add_expr_to_block (&fnblock, tmp);
6937 case COPY_ALLOC_COMP:
6938 if (c->attr.pointer)
6941 /* We need source and destination components. */
6942 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6944 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6946 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6948 if (c->attr.allocatable && !cmp_has_alloc_comps)
6950 rank = c->as ? c->as->rank : 0;
6951 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6952 gfc_add_expr_to_block (&fnblock, tmp);
6955 if (cmp_has_alloc_comps)
6957 rank = c->as ? c->as->rank : 0;
6958 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6959 gfc_add_modify (&fnblock, dcmp, tmp);
6960 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6962 gfc_add_expr_to_block (&fnblock, tmp);
6972 return gfc_finish_block (&fnblock);
6975 /* Recursively traverse an object of derived type, generating code to
6976 nullify allocatable components. */
6979 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6981 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6982 NULLIFY_ALLOC_COMP);
6986 /* Recursively traverse an object of derived type, generating code to
6987 deallocate allocatable components. */
6990 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6992 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6993 DEALLOCATE_ALLOC_COMP);
6997 /* Recursively traverse an object of derived type, generating code to
6998 copy it and its allocatable components. */
7001 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7003 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7007 /* Recursively traverse an object of derived type, generating code to
7008 copy only its allocatable components. */
7011 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7013 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7017 /* Returns the value of LBOUND for an expression. This could be broken out
7018 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7019 called by gfc_alloc_allocatable_for_assignment. */
7021 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7026 tree cond, cond1, cond3, cond4;
7030 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7032 tmp = gfc_rank_cst[dim];
7033 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7034 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7035 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7036 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7038 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7039 stride, gfc_index_zero_node);
7040 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7041 boolean_type_node, cond3, cond1);
7042 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7043 stride, gfc_index_zero_node);
7045 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7046 tmp, build_int_cst (gfc_array_index_type,
7049 cond = boolean_false_node;
7051 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7052 boolean_type_node, cond3, cond4);
7053 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7054 boolean_type_node, cond, cond1);
7056 return fold_build3_loc (input_location, COND_EXPR,
7057 gfc_array_index_type, cond,
7058 lbound, gfc_index_one_node);
7060 else if (expr->expr_type == EXPR_VARIABLE)
7062 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7063 for (ref = expr->ref; ref; ref = ref->next)
7065 if (ref->type == REF_COMPONENT
7066 && ref->u.c.component->as
7068 && ref->next->u.ar.type == AR_FULL)
7069 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7071 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7073 else if (expr->expr_type == EXPR_FUNCTION)
7075 /* A conversion function, so use the argument. */
7076 expr = expr->value.function.actual->expr;
7077 if (expr->expr_type != EXPR_VARIABLE)
7078 return gfc_index_one_node;
7079 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7080 return get_std_lbound (expr, desc, dim, assumed_size);
7083 return gfc_index_one_node;
7087 /* Returns true if an expression represents an lhs that can be reallocated
7091 gfc_is_reallocatable_lhs (gfc_expr *expr)
7098 /* An allocatable variable. */
7099 if (expr->symtree->n.sym->attr.allocatable
7101 && expr->ref->type == REF_ARRAY
7102 && expr->ref->u.ar.type == AR_FULL)
7105 /* All that can be left are allocatable components. */
7106 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7107 && expr->symtree->n.sym->ts.type != BT_CLASS)
7108 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7111 /* Find a component ref followed by an array reference. */
7112 for (ref = expr->ref; ref; ref = ref->next)
7114 && ref->type == REF_COMPONENT
7115 && ref->next->type == REF_ARRAY
7116 && !ref->next->next)
7122 /* Return true if valid reallocatable lhs. */
7123 if (ref->u.c.component->attr.allocatable
7124 && ref->next->u.ar.type == AR_FULL)
7131 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7135 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7139 stmtblock_t realloc_block;
7140 stmtblock_t alloc_block;
7163 gfc_array_spec * as;
7165 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7166 Find the lhs expression in the loop chain and set expr1 and
7167 expr2 accordingly. */
7168 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7171 /* Find the ss for the lhs. */
7173 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7174 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7176 if (lss == gfc_ss_terminator)
7181 /* Bail out if this is not a valid allocate on assignment. */
7182 if (!gfc_is_reallocatable_lhs (expr1)
7183 || (expr2 && !expr2->rank))
7186 /* Find the ss for the lhs. */
7188 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7189 if (lss->expr == expr1)
7192 if (lss == gfc_ss_terminator)
7195 /* Find an ss for the rhs. For operator expressions, we see the
7196 ss's for the operands. Any one of these will do. */
7198 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7199 if (rss->expr != expr1 && rss != loop->temp_ss)
7202 if (expr2 && rss == gfc_ss_terminator)
7205 gfc_start_block (&fblock);
7207 /* Since the lhs is allocatable, this must be a descriptor type.
7208 Get the data and array size. */
7209 desc = lss->data.info.descriptor;
7210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7211 array1 = gfc_conv_descriptor_data_get (desc);
7213 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7214 deallocated if expr is an array of different shape or any of the
7215 corresponding length type parameter values of variable and expr
7216 differ." This assures F95 compatibility. */
7217 jump_label1 = gfc_build_label_decl (NULL_TREE);
7218 jump_label2 = gfc_build_label_decl (NULL_TREE);
7220 /* Allocate if data is NULL. */
7221 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7222 array1, build_int_cst (TREE_TYPE (array1), 0));
7223 tmp = build3_v (COND_EXPR, cond,
7224 build1_v (GOTO_EXPR, jump_label1),
7225 build_empty_stmt (input_location));
7226 gfc_add_expr_to_block (&fblock, tmp);
7228 /* Get arrayspec if expr is a full array. */
7229 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7230 && expr2->value.function.isym
7231 && expr2->value.function.isym->conversion)
7233 /* For conversion functions, take the arg. */
7234 gfc_expr *arg = expr2->value.function.actual->expr;
7235 as = gfc_get_full_arrayspec_from_expr (arg);
7238 as = gfc_get_full_arrayspec_from_expr (expr2);
7242 /* If the lhs shape is not the same as the rhs jump to setting the
7243 bounds and doing the reallocation....... */
7244 for (n = 0; n < expr1->rank; n++)
7246 /* Check the shape. */
7247 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7248 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7249 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7250 gfc_array_index_type,
7251 loop->to[n], loop->from[n]);
7252 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7253 gfc_array_index_type,
7255 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7256 gfc_array_index_type,
7258 cond = fold_build2_loc (input_location, NE_EXPR,
7260 tmp, gfc_index_zero_node);
7261 tmp = build3_v (COND_EXPR, cond,
7262 build1_v (GOTO_EXPR, jump_label1),
7263 build_empty_stmt (input_location));
7264 gfc_add_expr_to_block (&fblock, tmp);
7267 /* ....else jump past the (re)alloc code. */
7268 tmp = build1_v (GOTO_EXPR, jump_label2);
7269 gfc_add_expr_to_block (&fblock, tmp);
7271 /* Add the label to start automatic (re)allocation. */
7272 tmp = build1_v (LABEL_EXPR, jump_label1);
7273 gfc_add_expr_to_block (&fblock, tmp);
7275 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7277 /* Get the rhs size. Fix both sizes. */
7279 desc2 = rss->data.info.descriptor;
7282 size2 = gfc_index_one_node;
7283 for (n = 0; n < expr2->rank; n++)
7285 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7286 gfc_array_index_type,
7287 loop->to[n], loop->from[n]);
7288 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7289 gfc_array_index_type,
7290 tmp, gfc_index_one_node);
7291 size2 = fold_build2_loc (input_location, MULT_EXPR,
7292 gfc_array_index_type,
7296 size1 = gfc_evaluate_now (size1, &fblock);
7297 size2 = gfc_evaluate_now (size2, &fblock);
7299 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7301 neq_size = gfc_evaluate_now (cond, &fblock);
7304 /* Now modify the lhs descriptor and the associated scalarizer
7305 variables. F2003 7.4.1.3: "If variable is or becomes an
7306 unallocated allocatable variable, then it is allocated with each
7307 deferred type parameter equal to the corresponding type parameters
7308 of expr , with the shape of expr , and with each lower bound equal
7309 to the corresponding element of LBOUND(expr)."
7310 Reuse size1 to keep a dimension-by-dimension track of the
7311 stride of the new array. */
7312 size1 = gfc_index_one_node;
7313 offset = gfc_index_zero_node;
7315 for (n = 0; n < expr2->rank; n++)
7317 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7318 gfc_array_index_type,
7319 loop->to[n], loop->from[n]);
7320 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7321 gfc_array_index_type,
7322 tmp, gfc_index_one_node);
7324 lbound = gfc_index_one_node;
7329 lbd = get_std_lbound (expr2, desc2, n,
7330 as->type == AS_ASSUMED_SIZE);
7331 ubound = fold_build2_loc (input_location,
7333 gfc_array_index_type,
7335 ubound = fold_build2_loc (input_location,
7337 gfc_array_index_type,
7342 gfc_conv_descriptor_lbound_set (&fblock, desc,
7345 gfc_conv_descriptor_ubound_set (&fblock, desc,
7348 gfc_conv_descriptor_stride_set (&fblock, desc,
7351 lbound = gfc_conv_descriptor_lbound_get (desc,
7353 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7354 gfc_array_index_type,
7356 offset = fold_build2_loc (input_location, MINUS_EXPR,
7357 gfc_array_index_type,
7359 size1 = fold_build2_loc (input_location, MULT_EXPR,
7360 gfc_array_index_type,
7364 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7365 the array offset is saved and the info.offset is used for a
7366 running offset. Use the saved_offset instead. */
7367 tmp = gfc_conv_descriptor_offset (desc);
7368 gfc_add_modify (&fblock, tmp, offset);
7369 if (lss->data.info.saved_offset
7370 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7371 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7373 /* Now set the deltas for the lhs. */
7374 for (n = 0; n < expr1->rank; n++)
7376 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7377 dim = lss->data.info.dim[n];
7378 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7379 gfc_array_index_type, tmp,
7381 if (lss->data.info.delta[dim]
7382 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7383 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7386 /* Get the new lhs size in bytes. */
7387 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7389 tmp = expr2->ts.u.cl->backend_decl;
7390 gcc_assert (expr1->ts.u.cl->backend_decl);
7391 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7392 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7394 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7396 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7397 tmp = fold_build2_loc (input_location, MULT_EXPR,
7398 gfc_array_index_type, tmp,
7399 expr1->ts.u.cl->backend_decl);
7402 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7403 tmp = fold_convert (gfc_array_index_type, tmp);
7404 size2 = fold_build2_loc (input_location, MULT_EXPR,
7405 gfc_array_index_type,
7407 size2 = fold_convert (size_type_node, size2);
7408 size2 = gfc_evaluate_now (size2, &fblock);
7410 /* Realloc expression. Note that the scalarizer uses desc.data
7411 in the array reference - (*desc.data)[<element>]. */
7412 gfc_init_block (&realloc_block);
7413 tmp = build_call_expr_loc (input_location,
7414 built_in_decls[BUILT_IN_REALLOC], 2,
7415 fold_convert (pvoid_type_node, array1),
7417 gfc_conv_descriptor_data_set (&realloc_block,
7419 realloc_expr = gfc_finish_block (&realloc_block);
7421 /* Only reallocate if sizes are different. */
7422 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7423 build_empty_stmt (input_location));
7427 /* Malloc expression. */
7428 gfc_init_block (&alloc_block);
7429 tmp = build_call_expr_loc (input_location,
7430 built_in_decls[BUILT_IN_MALLOC], 1,
7432 gfc_conv_descriptor_data_set (&alloc_block,
7434 tmp = gfc_conv_descriptor_dtype (desc);
7435 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7436 alloc_expr = gfc_finish_block (&alloc_block);
7438 /* Malloc if not allocated; realloc otherwise. */
7439 tmp = build_int_cst (TREE_TYPE (array1), 0);
7440 cond = fold_build2_loc (input_location, EQ_EXPR,
7443 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7444 gfc_add_expr_to_block (&fblock, tmp);
7446 /* Make sure that the scalarizer data pointer is updated. */
7447 if (lss->data.info.data
7448 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7450 tmp = gfc_conv_descriptor_data_get (desc);
7451 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7454 /* Add the exit label. */
7455 tmp = build1_v (LABEL_EXPR, jump_label2);
7456 gfc_add_expr_to_block (&fblock, tmp);
7458 return gfc_finish_block (&fblock);
7462 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7463 Do likewise, recursively if necessary, with the allocatable components of
7467 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7473 stmtblock_t cleanup;
7476 bool sym_has_alloc_comp;
7478 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7479 || sym->ts.type == BT_CLASS)
7480 && sym->ts.u.derived->attr.alloc_comp;
7482 /* Make sure the frontend gets these right. */
7483 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7484 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7485 "allocatable attribute or derived type without allocatable "
7488 gfc_save_backend_locus (&loc);
7489 gfc_set_backend_locus (&sym->declared_at);
7490 gfc_init_block (&init);
7492 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7493 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7495 if (sym->ts.type == BT_CHARACTER
7496 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7498 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7499 gfc_trans_vla_type_sizes (sym, &init);
7502 /* Dummy, use associated and result variables don't need anything special. */
7503 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7505 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7506 gfc_restore_backend_locus (&loc);
7510 descriptor = sym->backend_decl;
7512 /* Although static, derived types with default initializers and
7513 allocatable components must not be nulled wholesale; instead they
7514 are treated component by component. */
7515 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7517 /* SAVEd variables are not freed on exit. */
7518 gfc_trans_static_array_pointer (sym);
7520 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7521 gfc_restore_backend_locus (&loc);
7525 /* Get the descriptor type. */
7526 type = TREE_TYPE (sym->backend_decl);
7528 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7531 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7533 if (sym->value == NULL
7534 || !gfc_has_default_initializer (sym->ts.u.derived))
7536 rank = sym->as ? sym->as->rank : 0;
7537 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7539 gfc_add_expr_to_block (&init, tmp);
7542 gfc_init_default_dt (sym, &init, false);
7545 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7547 /* If the backend_decl is not a descriptor, we must have a pointer
7549 descriptor = build_fold_indirect_ref_loc (input_location,
7551 type = TREE_TYPE (descriptor);
7554 /* NULLIFY the data pointer. */
7555 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7556 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7558 gfc_restore_backend_locus (&loc);
7559 gfc_init_block (&cleanup);
7561 /* Allocatable arrays need to be freed when they go out of scope.
7562 The allocatable components of pointers must not be touched. */
7563 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7564 && !sym->attr.pointer && !sym->attr.save)
7567 rank = sym->as ? sym->as->rank : 0;
7568 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7569 gfc_add_expr_to_block (&cleanup, tmp);
7572 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7573 && !sym->attr.save && !sym->attr.result)
7575 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7576 gfc_add_expr_to_block (&cleanup, tmp);
7579 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7580 gfc_finish_block (&cleanup));
7583 /************ Expression Walking Functions ******************/
7585 /* Walk a variable reference.
7587 Possible extension - multiple component subscripts.
7588 x(:,:) = foo%a(:)%b(:)
7590 forall (i=..., j=...)
7591 x(i,j) = foo%a(j)%b(i)
7593 This adds a fair amount of complexity because you need to deal with more
7594 than one ref. Maybe handle in a similar manner to vector subscripts.
7595 Maybe not worth the effort. */
7599 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7606 for (ref = expr->ref; ref; ref = ref->next)
7607 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7610 for (; ref; ref = ref->next)
7612 if (ref->type == REF_SUBSTRING)
7614 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
7615 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
7618 /* We're only interested in array sections from now on. */
7619 if (ref->type != REF_ARRAY)
7624 if (ar->as->rank == 0 && ref->next != NULL)
7626 /* Scalar coarray. */
7633 for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
7634 ss = gfc_get_scalar_ss (ss, ar->start[n]);
7638 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
7639 newss->data.info.ref = ref;
7641 /* Make sure array is the same as array(:,:), this way
7642 we don't need to special case all the time. */
7643 ar->dimen = ar->as->rank;
7645 for (n = 0; n < ar->dimen; n++)
7647 ar->dimen_type[n] = DIMEN_RANGE;
7649 gcc_assert (ar->start[n] == NULL);
7650 gcc_assert (ar->end[n] == NULL);
7651 gcc_assert (ar->stride[n] == NULL);
7653 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7655 newss->data.info.dim[n] = n;
7656 ar->dimen_type[n] = DIMEN_RANGE;
7658 gcc_assert (ar->start[n] == NULL);
7659 gcc_assert (ar->end[n] == NULL);
7665 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
7666 newss->data.info.ref = ref;
7668 /* We add SS chains for all the subscripts in the section. */
7669 for (n = 0; n < ar->dimen + ar->codimen; n++)
7673 switch (ar->dimen_type[n])
7675 case DIMEN_THIS_IMAGE:
7678 /* Add SS for elemental (scalar) subscripts. */
7679 gcc_assert (ar->start[n]);
7680 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
7681 indexss->loop_chain = gfc_ss_terminator;
7682 newss->data.info.subscript[n] = indexss;
7686 /* We don't add anything for sections, just remember this
7687 dimension for later. */
7688 newss->data.info.dim[newss->data.info.dimen
7689 + newss->data.info.codimen] = 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
7702 + newss->data.info.codimen] = n;
7704 newss->data.info.dimen++;
7708 /* We should know what sort of section it is by now. */
7712 /* We should have at least one non-elemental dimension. */
7713 gcc_assert (newss->data.info.dimen > 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);