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->info->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);
490 free_ss_info (gfc_ss_info *ss_info)
493 if (ss_info->refcount > 0)
496 gcc_assert (ss_info->refcount == 0);
504 gfc_free_ss (gfc_ss * ss)
506 gfc_ss_info *ss_info;
511 switch (ss_info->type)
514 for (n = 0; n < ss->dimen; n++)
516 if (ss_info->data.array.subscript[ss->dim[n]])
517 gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
525 free_ss_info (ss_info);
530 /* Creates and initializes an array type gfc_ss struct. */
533 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
536 gfc_ss_info *ss_info;
539 ss_info = gfc_get_ss_info ();
541 ss_info->type = type;
542 ss_info->expr = expr;
548 for (i = 0; i < ss->dimen; i++)
555 /* Creates and initializes a temporary type gfc_ss struct. */
558 gfc_get_temp_ss (tree type, tree string_length, int dimen)
561 gfc_ss_info *ss_info;
564 ss_info = gfc_get_ss_info ();
566 ss_info->type = GFC_SS_TEMP;
567 ss_info->string_length = string_length;
568 ss_info->data.temp.type = type;
572 ss->next = gfc_ss_terminator;
574 for (i = 0; i < ss->dimen; i++)
581 /* Creates and initializes a scalar type gfc_ss struct. */
584 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
587 gfc_ss_info *ss_info;
589 ss_info = gfc_get_ss_info ();
591 ss_info->type = GFC_SS_SCALAR;
592 ss_info->expr = expr;
602 /* Free all the SS associated with a loop. */
605 gfc_cleanup_loop (gfc_loopinfo * loop)
611 while (ss != gfc_ss_terminator)
613 gcc_assert (ss != NULL);
614 next = ss->loop_chain;
622 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
626 for (; ss != gfc_ss_terminator; ss = ss->next)
630 if (ss->info->type == GFC_SS_SCALAR
631 || ss->info->type == GFC_SS_REFERENCE
632 || ss->info->type == GFC_SS_TEMP)
635 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
636 if (ss->info->data.array.subscript[n] != NULL)
637 set_ss_loop (ss->info->data.array.subscript[n], loop);
642 /* Associate a SS chain with a loop. */
645 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
649 if (head == gfc_ss_terminator)
652 set_ss_loop (head, loop);
655 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
657 if (ss->next == gfc_ss_terminator)
658 ss->loop_chain = loop->ss;
660 ss->loop_chain = ss->next;
662 gcc_assert (ss == gfc_ss_terminator);
667 /* Generate an initializer for a static pointer or allocatable array. */
670 gfc_trans_static_array_pointer (gfc_symbol * sym)
674 gcc_assert (TREE_STATIC (sym->backend_decl));
675 /* Just zero the data member. */
676 type = TREE_TYPE (sym->backend_decl);
677 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
681 /* If the bounds of SE's loop have not yet been set, see if they can be
682 determined from array spec AS, which is the array spec of a called
683 function. MAPPING maps the callee's dummy arguments to the values
684 that the caller is passing. Add any initialization and finalization
688 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
689 gfc_se * se, gfc_array_spec * as)
697 if (as && as->type == AS_EXPLICIT)
698 for (n = 0; n < se->loop->dimen; n++)
700 dim = se->ss->dim[n];
701 gcc_assert (dim < as->rank);
702 gcc_assert (se->loop->dimen == as->rank);
703 if (se->loop->to[n] == NULL_TREE)
705 /* Evaluate the lower bound. */
706 gfc_init_se (&tmpse, NULL);
707 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
708 gfc_add_block_to_block (&se->pre, &tmpse.pre);
709 gfc_add_block_to_block (&se->post, &tmpse.post);
710 lower = fold_convert (gfc_array_index_type, tmpse.expr);
712 /* ...and the upper bound. */
713 gfc_init_se (&tmpse, NULL);
714 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
715 gfc_add_block_to_block (&se->pre, &tmpse.pre);
716 gfc_add_block_to_block (&se->post, &tmpse.post);
717 upper = fold_convert (gfc_array_index_type, tmpse.expr);
719 /* Set the upper bound of the loop to UPPER - LOWER. */
720 tmp = fold_build2_loc (input_location, MINUS_EXPR,
721 gfc_array_index_type, upper, lower);
722 tmp = gfc_evaluate_now (tmp, &se->pre);
723 se->loop->to[n] = tmp;
729 /* Generate code to allocate an array temporary, or create a variable to
730 hold the data. If size is NULL, zero the descriptor so that the
731 callee will allocate the array. If DEALLOC is true, also generate code to
732 free the array afterwards.
734 If INITIAL is not NULL, it is packed using internal_pack and the result used
735 as data instead of allocating a fresh, unitialized area of memory.
737 Initialization code is added to PRE and finalization code to POST.
738 DYNAMIC is true if the caller may want to extend the array later
739 using realloc. This prevents us from putting the array on the stack. */
742 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
743 gfc_array_info * info, tree size, tree nelem,
744 tree initial, bool dynamic, bool dealloc)
750 desc = info->descriptor;
751 info->offset = gfc_index_zero_node;
752 if (size == NULL_TREE || integer_zerop (size))
754 /* A callee allocated array. */
755 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
760 /* Allocate the temporary. */
761 onstack = !dynamic && initial == NULL_TREE
762 && (gfc_option.flag_stack_arrays
763 || gfc_can_put_var_on_stack (size));
767 /* Make a temporary variable to hold the data. */
768 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
769 nelem, gfc_index_one_node);
770 tmp = gfc_evaluate_now (tmp, pre);
771 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
773 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
775 tmp = gfc_create_var (tmp, "A");
776 /* If we're here only because of -fstack-arrays we have to
777 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
778 if (!gfc_can_put_var_on_stack (size))
779 gfc_add_expr_to_block (pre,
780 fold_build1_loc (input_location,
781 DECL_EXPR, TREE_TYPE (tmp),
783 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
784 gfc_conv_descriptor_data_set (pre, desc, tmp);
788 /* Allocate memory to hold the data or call internal_pack. */
789 if (initial == NULL_TREE)
791 tmp = gfc_call_malloc (pre, NULL, size);
792 tmp = gfc_evaluate_now (tmp, pre);
799 stmtblock_t do_copying;
801 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
802 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
803 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
804 tmp = gfc_get_element_type (tmp);
805 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
806 packed = gfc_create_var (build_pointer_type (tmp), "data");
808 tmp = build_call_expr_loc (input_location,
809 gfor_fndecl_in_pack, 1, initial);
810 tmp = fold_convert (TREE_TYPE (packed), tmp);
811 gfc_add_modify (pre, packed, tmp);
813 tmp = build_fold_indirect_ref_loc (input_location,
815 source_data = gfc_conv_descriptor_data_get (tmp);
817 /* internal_pack may return source->data without any allocation
818 or copying if it is already packed. If that's the case, we
819 need to allocate and copy manually. */
821 gfc_start_block (&do_copying);
822 tmp = gfc_call_malloc (&do_copying, NULL, size);
823 tmp = fold_convert (TREE_TYPE (packed), tmp);
824 gfc_add_modify (&do_copying, packed, tmp);
825 tmp = gfc_build_memcpy_call (packed, source_data, size);
826 gfc_add_expr_to_block (&do_copying, tmp);
828 was_packed = fold_build2_loc (input_location, EQ_EXPR,
829 boolean_type_node, packed,
831 tmp = gfc_finish_block (&do_copying);
832 tmp = build3_v (COND_EXPR, was_packed, tmp,
833 build_empty_stmt (input_location));
834 gfc_add_expr_to_block (pre, tmp);
836 tmp = fold_convert (pvoid_type_node, packed);
839 gfc_conv_descriptor_data_set (pre, desc, tmp);
842 info->data = gfc_conv_descriptor_data_get (desc);
844 /* The offset is zero because we create temporaries with a zero
846 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
848 if (dealloc && !onstack)
850 /* Free the temporary. */
851 tmp = gfc_conv_descriptor_data_get (desc);
852 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
853 gfc_add_expr_to_block (post, tmp);
858 /* Get the array reference dimension corresponding to the given loop dimension.
859 It is different from the true array dimension given by the dim array in
860 the case of a partial array reference
861 It is different from the loop dimension in the case of a transposed array.
865 get_array_ref_dim (gfc_ss *ss, int loop_dim)
867 int n, array_dim, array_ref_dim;
870 array_dim = ss->dim[loop_dim];
872 for (n = 0; n < ss->dimen; n++)
873 if (ss->dim[n] < array_dim)
876 return array_ref_dim;
880 /* Generate code to create and initialize the descriptor for a temporary
881 array. This is used for both temporaries needed by the scalarizer, and
882 functions returning arrays. Adjusts the loop variables to be
883 zero-based, and calculates the loop bounds for callee allocated arrays.
884 Allocate the array unless it's callee allocated (we have a callee
885 allocated array if 'callee_alloc' is true, or if loop->to[n] is
886 NULL_TREE for any n). Also fills in the descriptor, data and offset
887 fields of info if known. Returns the size of the array, or NULL for a
888 callee allocated array.
890 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
891 gfc_trans_allocate_array_storage. */
894 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
895 tree eltype, tree initial, bool dynamic,
896 bool dealloc, bool callee_alloc, locus * where)
899 gfc_array_info *info;
900 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
911 memset (from, 0, sizeof (from));
912 memset (to, 0, sizeof (to));
914 info = &ss->info->data.array;
916 gcc_assert (ss->dimen > 0);
917 gcc_assert (ss->loop->dimen == ss->dimen);
919 if (gfc_option.warn_array_temp && where)
920 gfc_warning ("Creating array temporary at %L", where);
923 total_dim = loop->dimen;
924 /* Set the lower bound to zero. */
925 for (n = 0; n < loop->dimen; n++)
929 /* Callee allocated arrays may not have a known bound yet. */
931 loop->to[n] = gfc_evaluate_now (
932 fold_build2_loc (input_location, MINUS_EXPR,
933 gfc_array_index_type,
934 loop->to[n], loop->from[n]),
936 loop->from[n] = gfc_index_zero_node;
938 /* We have just changed the loop bounds, we must clear the
939 corresponding specloop, so that delta calculation is not skipped
940 later in set_delta. */
941 loop->specloop[n] = NULL;
943 /* We are constructing the temporary's descriptor based on the loop
944 dimensions. As the dimensions may be accessed in arbitrary order
945 (think of transpose) the size taken from the n'th loop may not map
946 to the n'th dimension of the array. We need to reconstruct loop infos
947 in the right order before using it to set the descriptor
949 tmp_dim = get_array_ref_dim (ss, n);
950 from[tmp_dim] = loop->from[n];
951 to[tmp_dim] = loop->to[n];
953 info->delta[dim] = gfc_index_zero_node;
954 info->start[dim] = gfc_index_zero_node;
955 info->end[dim] = gfc_index_zero_node;
956 info->stride[dim] = gfc_index_one_node;
959 /* Initialize the descriptor. */
961 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
962 GFC_ARRAY_UNKNOWN, true);
963 desc = gfc_create_var (type, "atmp");
964 GFC_DECL_PACKED_ARRAY (desc) = 1;
966 info->descriptor = desc;
967 size = gfc_index_one_node;
969 /* Fill in the array dtype. */
970 tmp = gfc_conv_descriptor_dtype (desc);
971 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
974 Fill in the bounds and stride. This is a packed array, so:
977 for (n = 0; n < rank; n++)
980 delta = ubound[n] + 1 - lbound[n];
983 size = size * sizeof(element);
988 /* If there is at least one null loop->to[n], it is a callee allocated
990 for (n = 0; n < total_dim; n++)
991 if (to[n] == NULL_TREE)
997 if (size == NULL_TREE)
999 for (n = 0; n < loop->dimen; n++)
1003 /* For a callee allocated array express the loop bounds in terms
1004 of the descriptor fields. */
1005 tmp = fold_build2_loc (input_location,
1006 MINUS_EXPR, gfc_array_index_type,
1007 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1008 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1014 for (n = 0; n < total_dim; n++)
1016 /* Store the stride and bound components in the descriptor. */
1017 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1019 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1020 gfc_index_zero_node);
1022 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1024 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1025 gfc_array_index_type,
1026 to[n], gfc_index_one_node);
1028 /* Check whether the size for this dimension is negative. */
1029 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1030 tmp, gfc_index_zero_node);
1031 cond = gfc_evaluate_now (cond, pre);
1036 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1037 boolean_type_node, or_expr, cond);
1039 size = fold_build2_loc (input_location, MULT_EXPR,
1040 gfc_array_index_type, size, tmp);
1041 size = gfc_evaluate_now (size, pre);
1045 /* Get the size of the array. */
1046 if (size && !callee_alloc)
1048 /* If or_expr is true, then the extent in at least one
1049 dimension is zero and the size is set to zero. */
1050 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1051 or_expr, gfc_index_zero_node, size);
1054 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1056 fold_convert (gfc_array_index_type,
1057 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
1065 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1068 if (ss->dimen > ss->loop->temp_dim)
1069 ss->loop->temp_dim = ss->dimen;
1075 /* Return the number of iterations in a loop that starts at START,
1076 ends at END, and has step STEP. */
1079 gfc_get_iteration_count (tree start, tree end, tree step)
1084 type = TREE_TYPE (step);
1085 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1086 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1087 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1088 build_int_cst (type, 1));
1089 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1090 build_int_cst (type, 0));
1091 return fold_convert (gfc_array_index_type, tmp);
1095 /* Extend the data in array DESC by EXTRA elements. */
1098 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1105 if (integer_zerop (extra))
1108 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1110 /* Add EXTRA to the upper bound. */
1111 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1113 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1115 /* Get the value of the current data pointer. */
1116 arg0 = gfc_conv_descriptor_data_get (desc);
1118 /* Calculate the new array size. */
1119 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1120 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1121 ubound, gfc_index_one_node);
1122 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1123 fold_convert (size_type_node, tmp),
1124 fold_convert (size_type_node, size));
1126 /* Call the realloc() function. */
1127 tmp = gfc_call_realloc (pblock, arg0, arg1);
1128 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1132 /* Return true if the bounds of iterator I can only be determined
1136 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1138 return (i->start->expr_type != EXPR_CONSTANT
1139 || i->end->expr_type != EXPR_CONSTANT
1140 || i->step->expr_type != EXPR_CONSTANT);
1144 /* Split the size of constructor element EXPR into the sum of two terms,
1145 one of which can be determined at compile time and one of which must
1146 be calculated at run time. Set *SIZE to the former and return true
1147 if the latter might be nonzero. */
1150 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1152 if (expr->expr_type == EXPR_ARRAY)
1153 return gfc_get_array_constructor_size (size, expr->value.constructor);
1154 else if (expr->rank > 0)
1156 /* Calculate everything at run time. */
1157 mpz_set_ui (*size, 0);
1162 /* A single element. */
1163 mpz_set_ui (*size, 1);
1169 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1170 of array constructor C. */
1173 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1181 mpz_set_ui (*size, 0);
1186 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1189 if (i && gfc_iterator_has_dynamic_bounds (i))
1193 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1196 /* Multiply the static part of the element size by the
1197 number of iterations. */
1198 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1199 mpz_fdiv_q (val, val, i->step->value.integer);
1200 mpz_add_ui (val, val, 1);
1201 if (mpz_sgn (val) > 0)
1202 mpz_mul (len, len, val);
1204 mpz_set_ui (len, 0);
1206 mpz_add (*size, *size, len);
1215 /* Make sure offset is a variable. */
1218 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1221 /* We should have already created the offset variable. We cannot
1222 create it here because we may be in an inner scope. */
1223 gcc_assert (*offsetvar != NULL_TREE);
1224 gfc_add_modify (pblock, *offsetvar, *poffset);
1225 *poffset = *offsetvar;
1226 TREE_USED (*offsetvar) = 1;
1230 /* Variables needed for bounds-checking. */
1231 static bool first_len;
1232 static tree first_len_val;
1233 static bool typespec_chararray_ctor;
1236 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1237 tree offset, gfc_se * se, gfc_expr * expr)
1241 gfc_conv_expr (se, expr);
1243 /* Store the value. */
1244 tmp = build_fold_indirect_ref_loc (input_location,
1245 gfc_conv_descriptor_data_get (desc));
1246 tmp = gfc_build_array_ref (tmp, offset, NULL);
1248 if (expr->ts.type == BT_CHARACTER)
1250 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1253 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1254 esize = fold_convert (gfc_charlen_type_node, esize);
1255 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1256 gfc_charlen_type_node, esize,
1257 build_int_cst (gfc_charlen_type_node,
1258 gfc_character_kinds[i].bit_size / 8));
1260 gfc_conv_string_parameter (se);
1261 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1263 /* The temporary is an array of pointers. */
1264 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1265 gfc_add_modify (&se->pre, tmp, se->expr);
1269 /* The temporary is an array of string values. */
1270 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1271 /* We know the temporary and the value will be the same length,
1272 so can use memcpy. */
1273 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1274 se->string_length, se->expr, expr->ts.kind);
1276 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1280 gfc_add_modify (&se->pre, first_len_val,
1286 /* Verify that all constructor elements are of the same
1288 tree cond = fold_build2_loc (input_location, NE_EXPR,
1289 boolean_type_node, first_len_val,
1291 gfc_trans_runtime_check
1292 (true, false, cond, &se->pre, &expr->where,
1293 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1294 fold_convert (long_integer_type_node, first_len_val),
1295 fold_convert (long_integer_type_node, se->string_length));
1301 /* TODO: Should the frontend already have done this conversion? */
1302 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1303 gfc_add_modify (&se->pre, tmp, se->expr);
1306 gfc_add_block_to_block (pblock, &se->pre);
1307 gfc_add_block_to_block (pblock, &se->post);
1311 /* Add the contents of an array to the constructor. DYNAMIC is as for
1312 gfc_trans_array_constructor_value. */
1315 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1316 tree type ATTRIBUTE_UNUSED,
1317 tree desc, gfc_expr * expr,
1318 tree * poffset, tree * offsetvar,
1329 /* We need this to be a variable so we can increment it. */
1330 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1332 gfc_init_se (&se, NULL);
1334 /* Walk the array expression. */
1335 ss = gfc_walk_expr (expr);
1336 gcc_assert (ss != gfc_ss_terminator);
1338 /* Initialize the scalarizer. */
1339 gfc_init_loopinfo (&loop);
1340 gfc_add_ss_to_loop (&loop, ss);
1342 /* Initialize the loop. */
1343 gfc_conv_ss_startstride (&loop);
1344 gfc_conv_loop_setup (&loop, &expr->where);
1346 /* Make sure the constructed array has room for the new data. */
1349 /* Set SIZE to the total number of elements in the subarray. */
1350 size = gfc_index_one_node;
1351 for (n = 0; n < loop.dimen; n++)
1353 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1354 gfc_index_one_node);
1355 size = fold_build2_loc (input_location, MULT_EXPR,
1356 gfc_array_index_type, size, tmp);
1359 /* Grow the constructed array by SIZE elements. */
1360 gfc_grow_array (&loop.pre, desc, size);
1363 /* Make the loop body. */
1364 gfc_mark_ss_chain_used (ss, 1);
1365 gfc_start_scalarized_body (&loop, &body);
1366 gfc_copy_loopinfo_to_se (&se, &loop);
1369 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1370 gcc_assert (se.ss == gfc_ss_terminator);
1372 /* Increment the offset. */
1373 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1374 *poffset, gfc_index_one_node);
1375 gfc_add_modify (&body, *poffset, tmp);
1377 /* Finish the loop. */
1378 gfc_trans_scalarizing_loops (&loop, &body);
1379 gfc_add_block_to_block (&loop.pre, &loop.post);
1380 tmp = gfc_finish_block (&loop.pre);
1381 gfc_add_expr_to_block (pblock, tmp);
1383 gfc_cleanup_loop (&loop);
1387 /* Assign the values to the elements of an array constructor. DYNAMIC
1388 is true if descriptor DESC only contains enough data for the static
1389 size calculated by gfc_get_array_constructor_size. When true, memory
1390 for the dynamic parts must be allocated using realloc. */
1393 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1394 tree desc, gfc_constructor_base base,
1395 tree * poffset, tree * offsetvar,
1404 tree shadow_loopvar = NULL_TREE;
1405 gfc_saved_var saved_loopvar;
1408 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1410 /* If this is an iterator or an array, the offset must be a variable. */
1411 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1412 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1414 /* Shadowing the iterator avoids changing its value and saves us from
1415 keeping track of it. Further, it makes sure that there's always a
1416 backend-decl for the symbol, even if there wasn't one before,
1417 e.g. in the case of an iterator that appears in a specification
1418 expression in an interface mapping. */
1421 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1422 tree type = gfc_typenode_for_spec (&sym->ts);
1424 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1425 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1428 gfc_start_block (&body);
1430 if (c->expr->expr_type == EXPR_ARRAY)
1432 /* Array constructors can be nested. */
1433 gfc_trans_array_constructor_value (&body, type, desc,
1434 c->expr->value.constructor,
1435 poffset, offsetvar, dynamic);
1437 else if (c->expr->rank > 0)
1439 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1440 poffset, offsetvar, dynamic);
1444 /* This code really upsets the gimplifier so don't bother for now. */
1451 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1453 p = gfc_constructor_next (p);
1458 /* Scalar values. */
1459 gfc_init_se (&se, NULL);
1460 gfc_trans_array_ctor_element (&body, desc, *poffset,
1463 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1464 gfc_array_index_type,
1465 *poffset, gfc_index_one_node);
1469 /* Collect multiple scalar constants into a constructor. */
1470 VEC(constructor_elt,gc) *v = NULL;
1474 HOST_WIDE_INT idx = 0;
1477 /* Count the number of consecutive scalar constants. */
1478 while (p && !(p->iterator
1479 || p->expr->expr_type != EXPR_CONSTANT))
1481 gfc_init_se (&se, NULL);
1482 gfc_conv_constant (&se, p->expr);
1484 if (c->expr->ts.type != BT_CHARACTER)
1485 se.expr = fold_convert (type, se.expr);
1486 /* For constant character array constructors we build
1487 an array of pointers. */
1488 else if (POINTER_TYPE_P (type))
1489 se.expr = gfc_build_addr_expr
1490 (gfc_get_pchar_type (p->expr->ts.kind),
1493 CONSTRUCTOR_APPEND_ELT (v,
1494 build_int_cst (gfc_array_index_type,
1498 p = gfc_constructor_next (p);
1501 bound = size_int (n - 1);
1502 /* Create an array type to hold them. */
1503 tmptype = build_range_type (gfc_array_index_type,
1504 gfc_index_zero_node, bound);
1505 tmptype = build_array_type (type, tmptype);
1507 init = build_constructor (tmptype, v);
1508 TREE_CONSTANT (init) = 1;
1509 TREE_STATIC (init) = 1;
1510 /* Create a static variable to hold the data. */
1511 tmp = gfc_create_var (tmptype, "data");
1512 TREE_STATIC (tmp) = 1;
1513 TREE_CONSTANT (tmp) = 1;
1514 TREE_READONLY (tmp) = 1;
1515 DECL_INITIAL (tmp) = init;
1518 /* Use BUILTIN_MEMCPY to assign the values. */
1519 tmp = gfc_conv_descriptor_data_get (desc);
1520 tmp = build_fold_indirect_ref_loc (input_location,
1522 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1523 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1524 init = gfc_build_addr_expr (NULL_TREE, init);
1526 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1527 bound = build_int_cst (size_type_node, n * size);
1528 tmp = build_call_expr_loc (input_location,
1529 builtin_decl_explicit (BUILT_IN_MEMCPY),
1530 3, tmp, init, bound);
1531 gfc_add_expr_to_block (&body, tmp);
1533 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1534 gfc_array_index_type, *poffset,
1535 build_int_cst (gfc_array_index_type, n));
1537 if (!INTEGER_CST_P (*poffset))
1539 gfc_add_modify (&body, *offsetvar, *poffset);
1540 *poffset = *offsetvar;
1544 /* The frontend should already have done any expansions
1548 /* Pass the code as is. */
1549 tmp = gfc_finish_block (&body);
1550 gfc_add_expr_to_block (pblock, tmp);
1554 /* Build the implied do-loop. */
1555 stmtblock_t implied_do_block;
1563 loopbody = gfc_finish_block (&body);
1565 /* Create a new block that holds the implied-do loop. A temporary
1566 loop-variable is used. */
1567 gfc_start_block(&implied_do_block);
1569 /* Initialize the loop. */
1570 gfc_init_se (&se, NULL);
1571 gfc_conv_expr_val (&se, c->iterator->start);
1572 gfc_add_block_to_block (&implied_do_block, &se.pre);
1573 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1575 gfc_init_se (&se, NULL);
1576 gfc_conv_expr_val (&se, c->iterator->end);
1577 gfc_add_block_to_block (&implied_do_block, &se.pre);
1578 end = gfc_evaluate_now (se.expr, &implied_do_block);
1580 gfc_init_se (&se, NULL);
1581 gfc_conv_expr_val (&se, c->iterator->step);
1582 gfc_add_block_to_block (&implied_do_block, &se.pre);
1583 step = gfc_evaluate_now (se.expr, &implied_do_block);
1585 /* If this array expands dynamically, and the number of iterations
1586 is not constant, we won't have allocated space for the static
1587 part of C->EXPR's size. Do that now. */
1588 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1590 /* Get the number of iterations. */
1591 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1593 /* Get the static part of C->EXPR's size. */
1594 gfc_get_array_constructor_element_size (&size, c->expr);
1595 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1597 /* Grow the array by TMP * TMP2 elements. */
1598 tmp = fold_build2_loc (input_location, MULT_EXPR,
1599 gfc_array_index_type, tmp, tmp2);
1600 gfc_grow_array (&implied_do_block, desc, tmp);
1603 /* Generate the loop body. */
1604 exit_label = gfc_build_label_decl (NULL_TREE);
1605 gfc_start_block (&body);
1607 /* Generate the exit condition. Depending on the sign of
1608 the step variable we have to generate the correct
1610 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1611 step, build_int_cst (TREE_TYPE (step), 0));
1612 cond = fold_build3_loc (input_location, COND_EXPR,
1613 boolean_type_node, tmp,
1614 fold_build2_loc (input_location, GT_EXPR,
1615 boolean_type_node, shadow_loopvar, end),
1616 fold_build2_loc (input_location, LT_EXPR,
1617 boolean_type_node, shadow_loopvar, end));
1618 tmp = build1_v (GOTO_EXPR, exit_label);
1619 TREE_USED (exit_label) = 1;
1620 tmp = build3_v (COND_EXPR, cond, tmp,
1621 build_empty_stmt (input_location));
1622 gfc_add_expr_to_block (&body, tmp);
1624 /* The main loop body. */
1625 gfc_add_expr_to_block (&body, loopbody);
1627 /* Increase loop variable by step. */
1628 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1629 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1631 gfc_add_modify (&body, shadow_loopvar, tmp);
1633 /* Finish the loop. */
1634 tmp = gfc_finish_block (&body);
1635 tmp = build1_v (LOOP_EXPR, tmp);
1636 gfc_add_expr_to_block (&implied_do_block, tmp);
1638 /* Add the exit label. */
1639 tmp = build1_v (LABEL_EXPR, exit_label);
1640 gfc_add_expr_to_block (&implied_do_block, tmp);
1642 /* Finishe the implied-do loop. */
1643 tmp = gfc_finish_block(&implied_do_block);
1644 gfc_add_expr_to_block(pblock, tmp);
1646 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1653 /* A catch-all to obtain the string length for anything that is not a
1654 a substring of non-constant length, a constant, array or variable. */
1657 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1662 /* Don't bother if we already know the length is a constant. */
1663 if (*len && INTEGER_CST_P (*len))
1666 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1667 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1670 gfc_conv_const_charlen (e->ts.u.cl);
1671 *len = e->ts.u.cl->backend_decl;
1675 /* Otherwise, be brutal even if inefficient. */
1676 ss = gfc_walk_expr (e);
1677 gfc_init_se (&se, NULL);
1679 /* No function call, in case of side effects. */
1680 se.no_function_call = 1;
1681 if (ss == gfc_ss_terminator)
1682 gfc_conv_expr (&se, e);
1684 gfc_conv_expr_descriptor (&se, e, ss);
1686 /* Fix the value. */
1687 *len = gfc_evaluate_now (se.string_length, &se.pre);
1689 gfc_add_block_to_block (block, &se.pre);
1690 gfc_add_block_to_block (block, &se.post);
1692 e->ts.u.cl->backend_decl = *len;
1697 /* Figure out the string length of a variable reference expression.
1698 Used by get_array_ctor_strlen. */
1701 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1707 /* Don't bother if we already know the length is a constant. */
1708 if (*len && INTEGER_CST_P (*len))
1711 ts = &expr->symtree->n.sym->ts;
1712 for (ref = expr->ref; ref; ref = ref->next)
1717 /* Array references don't change the string length. */
1721 /* Use the length of the component. */
1722 ts = &ref->u.c.component->ts;
1726 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1727 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1729 /* Note that this might evaluate expr. */
1730 get_array_ctor_all_strlen (block, expr, len);
1733 mpz_init_set_ui (char_len, 1);
1734 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1735 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1736 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1737 *len = convert (gfc_charlen_type_node, *len);
1738 mpz_clear (char_len);
1746 *len = ts->u.cl->backend_decl;
1750 /* Figure out the string length of a character array constructor.
1751 If len is NULL, don't calculate the length; this happens for recursive calls
1752 when a sub-array-constructor is an element but not at the first position,
1753 so when we're not interested in the length.
1754 Returns TRUE if all elements are character constants. */
1757 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1764 if (gfc_constructor_first (base) == NULL)
1767 *len = build_int_cstu (gfc_charlen_type_node, 0);
1771 /* Loop over all constructor elements to find out is_const, but in len we
1772 want to store the length of the first, not the last, element. We can
1773 of course exit the loop as soon as is_const is found to be false. */
1774 for (c = gfc_constructor_first (base);
1775 c && is_const; c = gfc_constructor_next (c))
1777 switch (c->expr->expr_type)
1780 if (len && !(*len && INTEGER_CST_P (*len)))
1781 *len = build_int_cstu (gfc_charlen_type_node,
1782 c->expr->value.character.length);
1786 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1793 get_array_ctor_var_strlen (block, c->expr, len);
1799 get_array_ctor_all_strlen (block, c->expr, len);
1803 /* After the first iteration, we don't want the length modified. */
1810 /* Check whether the array constructor C consists entirely of constant
1811 elements, and if so returns the number of those elements, otherwise
1812 return zero. Note, an empty or NULL array constructor returns zero. */
1814 unsigned HOST_WIDE_INT
1815 gfc_constant_array_constructor_p (gfc_constructor_base base)
1817 unsigned HOST_WIDE_INT nelem = 0;
1819 gfc_constructor *c = gfc_constructor_first (base);
1823 || c->expr->rank > 0
1824 || c->expr->expr_type != EXPR_CONSTANT)
1826 c = gfc_constructor_next (c);
1833 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1834 and the tree type of it's elements, TYPE, return a static constant
1835 variable that is compile-time initialized. */
1838 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1840 tree tmptype, init, tmp;
1841 HOST_WIDE_INT nelem;
1846 VEC(constructor_elt,gc) *v = NULL;
1848 /* First traverse the constructor list, converting the constants
1849 to tree to build an initializer. */
1851 c = gfc_constructor_first (expr->value.constructor);
1854 gfc_init_se (&se, NULL);
1855 gfc_conv_constant (&se, c->expr);
1856 if (c->expr->ts.type != BT_CHARACTER)
1857 se.expr = fold_convert (type, se.expr);
1858 else if (POINTER_TYPE_P (type))
1859 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1861 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1863 c = gfc_constructor_next (c);
1867 /* Next determine the tree type for the array. We use the gfortran
1868 front-end's gfc_get_nodesc_array_type in order to create a suitable
1869 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1871 memset (&as, 0, sizeof (gfc_array_spec));
1873 as.rank = expr->rank;
1874 as.type = AS_EXPLICIT;
1877 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1878 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1882 for (i = 0; i < expr->rank; i++)
1884 int tmp = (int) mpz_get_si (expr->shape[i]);
1885 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1886 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1890 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1892 /* as is not needed anymore. */
1893 for (i = 0; i < as.rank + as.corank; i++)
1895 gfc_free_expr (as.lower[i]);
1896 gfc_free_expr (as.upper[i]);
1899 init = build_constructor (tmptype, v);
1901 TREE_CONSTANT (init) = 1;
1902 TREE_STATIC (init) = 1;
1904 tmp = gfc_create_var (tmptype, "A");
1905 TREE_STATIC (tmp) = 1;
1906 TREE_CONSTANT (tmp) = 1;
1907 TREE_READONLY (tmp) = 1;
1908 DECL_INITIAL (tmp) = init;
1914 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1915 This mostly initializes the scalarizer state info structure with the
1916 appropriate values to directly use the array created by the function
1917 gfc_build_constant_array_constructor. */
1920 trans_constant_array_constructor (gfc_ss * ss, tree type)
1922 gfc_array_info *info;
1926 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
1928 info = &ss->info->data.array;
1930 info->descriptor = tmp;
1931 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1932 info->offset = gfc_index_zero_node;
1934 for (i = 0; i < ss->dimen; i++)
1936 info->delta[i] = gfc_index_zero_node;
1937 info->start[i] = gfc_index_zero_node;
1938 info->end[i] = gfc_index_zero_node;
1939 info->stride[i] = gfc_index_one_node;
1943 /* Helper routine of gfc_trans_array_constructor to determine if the
1944 bounds of the loop specified by LOOP are constant and simple enough
1945 to use with trans_constant_array_constructor. Returns the
1946 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1949 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1951 tree size = gfc_index_one_node;
1955 for (i = 0; i < loop->dimen; i++)
1957 /* If the bounds aren't constant, return NULL_TREE. */
1958 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1960 if (!integer_zerop (loop->from[i]))
1962 /* Only allow nonzero "from" in one-dimensional arrays. */
1963 if (loop->dimen != 1)
1965 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1966 gfc_array_index_type,
1967 loop->to[i], loop->from[i]);
1971 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1972 tmp, gfc_index_one_node);
1973 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1981 /* Array constructors are handled by constructing a temporary, then using that
1982 within the scalarization loop. This is not optimal, but seems by far the
1986 trans_array_constructor (gfc_ss * ss, locus * where)
1988 gfc_constructor_base c;
1995 bool old_first_len, old_typespec_chararray_ctor;
1996 tree old_first_len_val;
1998 gfc_ss_info *ss_info;
2001 /* Save the old values for nested checking. */
2002 old_first_len = first_len;
2003 old_first_len_val = first_len_val;
2004 old_typespec_chararray_ctor = typespec_chararray_ctor;
2008 expr = ss_info->expr;
2010 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2011 typespec was given for the array constructor. */
2012 typespec_chararray_ctor = (expr->ts.u.cl
2013 && expr->ts.u.cl->length_from_typespec);
2015 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2016 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2018 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2022 gcc_assert (ss->dimen == loop->dimen);
2024 c = expr->value.constructor;
2025 if (expr->ts.type == BT_CHARACTER)
2029 /* get_array_ctor_strlen walks the elements of the constructor, if a
2030 typespec was given, we already know the string length and want the one
2032 if (typespec_chararray_ctor && expr->ts.u.cl->length
2033 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2037 const_string = false;
2038 gfc_init_se (&length_se, NULL);
2039 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2040 gfc_charlen_type_node);
2041 ss_info->string_length = length_se.expr;
2042 gfc_add_block_to_block (&loop->pre, &length_se.pre);
2043 gfc_add_block_to_block (&loop->post, &length_se.post);
2046 const_string = get_array_ctor_strlen (&loop->pre, c,
2047 &ss_info->string_length);
2049 /* Complex character array constructors should have been taken care of
2050 and not end up here. */
2051 gcc_assert (ss_info->string_length);
2053 expr->ts.u.cl->backend_decl = ss_info->string_length;
2055 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2057 type = build_pointer_type (type);
2060 type = gfc_typenode_for_spec (&expr->ts);
2062 /* See if the constructor determines the loop bounds. */
2065 if (expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
2067 /* We have a multidimensional parameter. */
2069 for (n = 0; n < expr->rank; n++)
2071 loop->from[n] = gfc_index_zero_node;
2072 loop->to[n] = gfc_conv_mpz_to_tree (expr->shape [n],
2073 gfc_index_integer_kind);
2074 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2075 gfc_array_index_type,
2076 loop->to[n], gfc_index_one_node);
2080 if (loop->to[0] == NULL_TREE)
2084 /* We should have a 1-dimensional, zero-based loop. */
2085 gcc_assert (loop->dimen == 1);
2086 gcc_assert (integer_zerop (loop->from[0]));
2088 /* Split the constructor size into a static part and a dynamic part.
2089 Allocate the static size up-front and record whether the dynamic
2090 size might be nonzero. */
2092 dynamic = gfc_get_array_constructor_size (&size, c);
2093 mpz_sub_ui (size, size, 1);
2094 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2098 /* Special case constant array constructors. */
2101 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2104 tree size = constant_array_constructor_loop_size (loop);
2105 if (size && compare_tree_int (size, nelem) == 0)
2107 trans_constant_array_constructor (ss, type);
2113 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2116 gfc_trans_create_temp_array (&loop->pre, &loop->post, ss, type, NULL_TREE,
2117 dynamic, true, false, where);
2119 desc = ss_info->data.array.descriptor;
2120 offset = gfc_index_zero_node;
2121 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2122 TREE_NO_WARNING (offsetvar) = 1;
2123 TREE_USED (offsetvar) = 0;
2124 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2125 &offset, &offsetvar, dynamic);
2127 /* If the array grows dynamically, the upper bound of the loop variable
2128 is determined by the array's final upper bound. */
2131 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2132 gfc_array_index_type,
2133 offsetvar, gfc_index_one_node);
2134 tmp = gfc_evaluate_now (tmp, &loop->pre);
2135 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2136 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2137 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2142 if (TREE_USED (offsetvar))
2143 pushdecl (offsetvar);
2145 gcc_assert (INTEGER_CST_P (offset));
2148 /* Disable bound checking for now because it's probably broken. */
2149 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2156 /* Restore old values of globals. */
2157 first_len = old_first_len;
2158 first_len_val = old_first_len_val;
2159 typespec_chararray_ctor = old_typespec_chararray_ctor;
2163 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2164 called after evaluating all of INFO's vector dimensions. Go through
2165 each such vector dimension and see if we can now fill in any missing
2169 set_vector_loop_bounds (gfc_ss * ss)
2172 gfc_array_info *info;
2180 info = &ss->info->data.array;
2183 for (n = 0; n < loop->dimen; n++)
2186 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2187 && loop->to[n] == NULL)
2189 /* Loop variable N indexes vector dimension DIM, and we don't
2190 yet know the upper bound of loop variable N. Set it to the
2191 difference between the vector's upper and lower bounds. */
2192 gcc_assert (loop->from[n] == gfc_index_zero_node);
2193 gcc_assert (info->subscript[dim]
2194 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2196 gfc_init_se (&se, NULL);
2197 desc = info->subscript[dim]->info->data.array.descriptor;
2198 zero = gfc_rank_cst[0];
2199 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2200 gfc_array_index_type,
2201 gfc_conv_descriptor_ubound_get (desc, zero),
2202 gfc_conv_descriptor_lbound_get (desc, zero));
2203 tmp = gfc_evaluate_now (tmp, &loop->pre);
2210 /* Add the pre and post chains for all the scalar expressions in a SS chain
2211 to loop. This is called after the loop parameters have been calculated,
2212 but before the actual scalarizing loops. */
2215 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2219 gfc_ss_info *ss_info;
2220 gfc_array_info *info;
2224 /* TODO: This can generate bad code if there are ordering dependencies,
2225 e.g., a callee allocated function and an unknown size constructor. */
2226 gcc_assert (ss != NULL);
2228 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2233 expr = ss_info->expr;
2234 info = &ss_info->data.array;
2236 switch (ss_info->type)
2239 /* Scalar expression. Evaluate this now. This includes elemental
2240 dimension indices, but not array section bounds. */
2241 gfc_init_se (&se, NULL);
2242 gfc_conv_expr (&se, expr);
2243 gfc_add_block_to_block (&loop->pre, &se.pre);
2245 if (expr->ts.type != BT_CHARACTER)
2247 /* Move the evaluation of scalar expressions outside the
2248 scalarization loop, except for WHERE assignments. */
2250 se.expr = convert(gfc_array_index_type, se.expr);
2251 if (!ss_info->where)
2252 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2253 gfc_add_block_to_block (&loop->pre, &se.post);
2256 gfc_add_block_to_block (&loop->post, &se.post);
2258 ss_info->data.scalar.value = se.expr;
2259 ss_info->string_length = se.string_length;
2262 case GFC_SS_REFERENCE:
2263 /* Scalar argument to elemental procedure. Evaluate this
2265 gfc_init_se (&se, NULL);
2266 gfc_conv_expr (&se, expr);
2267 gfc_add_block_to_block (&loop->pre, &se.pre);
2268 gfc_add_block_to_block (&loop->post, &se.post);
2270 ss_info->data.scalar.value = gfc_evaluate_now (se.expr, &loop->pre);
2271 ss_info->string_length = se.string_length;
2274 case GFC_SS_SECTION:
2275 /* Add the expressions for scalar and vector subscripts. */
2276 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2277 if (info->subscript[n])
2278 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2280 set_vector_loop_bounds (ss);
2284 /* Get the vector's descriptor and store it in SS. */
2285 gfc_init_se (&se, NULL);
2286 gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2287 gfc_add_block_to_block (&loop->pre, &se.pre);
2288 gfc_add_block_to_block (&loop->post, &se.post);
2289 info->descriptor = se.expr;
2292 case GFC_SS_INTRINSIC:
2293 gfc_add_intrinsic_ss_code (loop, ss);
2296 case GFC_SS_FUNCTION:
2297 /* Array function return value. We call the function and save its
2298 result in a temporary for use inside the loop. */
2299 gfc_init_se (&se, NULL);
2302 gfc_conv_expr (&se, expr);
2303 gfc_add_block_to_block (&loop->pre, &se.pre);
2304 gfc_add_block_to_block (&loop->post, &se.post);
2305 ss_info->string_length = se.string_length;
2308 case GFC_SS_CONSTRUCTOR:
2309 if (expr->ts.type == BT_CHARACTER
2310 && ss_info->string_length == NULL
2312 && expr->ts.u.cl->length)
2314 gfc_init_se (&se, NULL);
2315 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2316 gfc_charlen_type_node);
2317 ss_info->string_length = se.expr;
2318 gfc_add_block_to_block (&loop->pre, &se.pre);
2319 gfc_add_block_to_block (&loop->post, &se.post);
2321 trans_array_constructor (ss, where);
2325 case GFC_SS_COMPONENT:
2326 /* Do nothing. These are handled elsewhere. */
2336 /* Translate expressions for the descriptor and data pointer of a SS. */
2340 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2343 gfc_ss_info *ss_info;
2344 gfc_array_info *info;
2348 info = &ss_info->data.array;
2350 /* Get the descriptor for the array to be scalarized. */
2351 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2352 gfc_init_se (&se, NULL);
2353 se.descriptor_only = 1;
2354 gfc_conv_expr_lhs (&se, ss_info->expr);
2355 gfc_add_block_to_block (block, &se.pre);
2356 info->descriptor = se.expr;
2357 ss_info->string_length = se.string_length;
2361 /* Also the data pointer. */
2362 tmp = gfc_conv_array_data (se.expr);
2363 /* If this is a variable or address of a variable we use it directly.
2364 Otherwise we must evaluate it now to avoid breaking dependency
2365 analysis by pulling the expressions for elemental array indices
2368 || (TREE_CODE (tmp) == ADDR_EXPR
2369 && DECL_P (TREE_OPERAND (tmp, 0)))))
2370 tmp = gfc_evaluate_now (tmp, block);
2373 tmp = gfc_conv_array_offset (se.expr);
2374 info->offset = gfc_evaluate_now (tmp, block);
2376 /* Make absolutely sure that the saved_offset is indeed saved
2377 so that the variable is still accessible after the loops
2379 info->saved_offset = info->offset;
2384 /* Initialize a gfc_loopinfo structure. */
2387 gfc_init_loopinfo (gfc_loopinfo * loop)
2391 memset (loop, 0, sizeof (gfc_loopinfo));
2392 gfc_init_block (&loop->pre);
2393 gfc_init_block (&loop->post);
2395 /* Initially scalarize in order and default to no loop reversal. */
2396 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2399 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2402 loop->ss = gfc_ss_terminator;
2406 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2410 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2416 /* Return an expression for the data pointer of an array. */
2419 gfc_conv_array_data (tree descriptor)
2423 type = TREE_TYPE (descriptor);
2424 if (GFC_ARRAY_TYPE_P (type))
2426 if (TREE_CODE (type) == POINTER_TYPE)
2430 /* Descriptorless arrays. */
2431 return gfc_build_addr_expr (NULL_TREE, descriptor);
2435 return gfc_conv_descriptor_data_get (descriptor);
2439 /* Return an expression for the base offset of an array. */
2442 gfc_conv_array_offset (tree descriptor)
2446 type = TREE_TYPE (descriptor);
2447 if (GFC_ARRAY_TYPE_P (type))
2448 return GFC_TYPE_ARRAY_OFFSET (type);
2450 return gfc_conv_descriptor_offset_get (descriptor);
2454 /* Get an expression for the array stride. */
2457 gfc_conv_array_stride (tree descriptor, int dim)
2462 type = TREE_TYPE (descriptor);
2464 /* For descriptorless arrays use the array size. */
2465 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2466 if (tmp != NULL_TREE)
2469 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2474 /* Like gfc_conv_array_stride, but for the lower bound. */
2477 gfc_conv_array_lbound (tree descriptor, int dim)
2482 type = TREE_TYPE (descriptor);
2484 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2485 if (tmp != NULL_TREE)
2488 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2493 /* Like gfc_conv_array_stride, but for the upper bound. */
2496 gfc_conv_array_ubound (tree descriptor, int dim)
2501 type = TREE_TYPE (descriptor);
2503 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2504 if (tmp != NULL_TREE)
2507 /* This should only ever happen when passing an assumed shape array
2508 as an actual parameter. The value will never be used. */
2509 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2510 return gfc_index_zero_node;
2512 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2517 /* Generate code to perform an array index bound check. */
2520 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2521 locus * where, bool check_upper)
2524 tree tmp_lo, tmp_up;
2527 const char * name = NULL;
2529 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2532 descriptor = ss->info->data.array.descriptor;
2534 index = gfc_evaluate_now (index, &se->pre);
2536 /* We find a name for the error message. */
2537 name = ss->info->expr->symtree->n.sym->name;
2538 gcc_assert (name != NULL);
2540 if (TREE_CODE (descriptor) == VAR_DECL)
2541 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2543 /* If upper bound is present, include both bounds in the error message. */
2546 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2547 tmp_up = gfc_conv_array_ubound (descriptor, n);
2550 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2551 "outside of expected range (%%ld:%%ld)", n+1, name);
2553 asprintf (&msg, "Index '%%ld' of dimension %d "
2554 "outside of expected range (%%ld:%%ld)", n+1);
2556 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2558 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2559 fold_convert (long_integer_type_node, index),
2560 fold_convert (long_integer_type_node, tmp_lo),
2561 fold_convert (long_integer_type_node, tmp_up));
2562 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2564 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2565 fold_convert (long_integer_type_node, index),
2566 fold_convert (long_integer_type_node, tmp_lo),
2567 fold_convert (long_integer_type_node, tmp_up));
2572 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2575 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2576 "below lower bound of %%ld", n+1, name);
2578 asprintf (&msg, "Index '%%ld' of dimension %d "
2579 "below lower bound of %%ld", n+1);
2581 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2583 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2584 fold_convert (long_integer_type_node, index),
2585 fold_convert (long_integer_type_node, tmp_lo));
2593 /* Return the offset for an index. Performs bound checking for elemental
2594 dimensions. Single element references are processed separately.
2595 DIM is the array dimension, I is the loop dimension. */
2598 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2599 gfc_array_ref * ar, tree stride)
2601 gfc_array_info *info;
2606 info = &ss->info->data.array;
2608 /* Get the index into the array for this dimension. */
2611 gcc_assert (ar->type != AR_ELEMENT);
2612 switch (ar->dimen_type[dim])
2614 case DIMEN_THIS_IMAGE:
2618 /* Elemental dimension. */
2619 gcc_assert (info->subscript[dim]
2620 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2621 /* We've already translated this value outside the loop. */
2622 index = info->subscript[dim]->info->data.scalar.value;
2624 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2625 ar->as->type != AS_ASSUMED_SIZE
2626 || dim < ar->dimen - 1);
2630 gcc_assert (info && se->loop);
2631 gcc_assert (info->subscript[dim]
2632 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2633 desc = info->subscript[dim]->info->data.array.descriptor;
2635 /* Get a zero-based index into the vector. */
2636 index = fold_build2_loc (input_location, MINUS_EXPR,
2637 gfc_array_index_type,
2638 se->loop->loopvar[i], se->loop->from[i]);
2640 /* Multiply the index by the stride. */
2641 index = fold_build2_loc (input_location, MULT_EXPR,
2642 gfc_array_index_type,
2643 index, gfc_conv_array_stride (desc, 0));
2645 /* Read the vector to get an index into info->descriptor. */
2646 data = build_fold_indirect_ref_loc (input_location,
2647 gfc_conv_array_data (desc));
2648 index = gfc_build_array_ref (data, index, NULL);
2649 index = gfc_evaluate_now (index, &se->pre);
2650 index = fold_convert (gfc_array_index_type, index);
2652 /* Do any bounds checking on the final info->descriptor index. */
2653 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2654 ar->as->type != AS_ASSUMED_SIZE
2655 || dim < ar->dimen - 1);
2659 /* Scalarized dimension. */
2660 gcc_assert (info && se->loop);
2662 /* Multiply the loop variable by the stride and delta. */
2663 index = se->loop->loopvar[i];
2664 if (!integer_onep (info->stride[dim]))
2665 index = fold_build2_loc (input_location, MULT_EXPR,
2666 gfc_array_index_type, index,
2668 if (!integer_zerop (info->delta[dim]))
2669 index = fold_build2_loc (input_location, PLUS_EXPR,
2670 gfc_array_index_type, index,
2680 /* Temporary array or derived type component. */
2681 gcc_assert (se->loop);
2682 index = se->loop->loopvar[se->loop->order[i]];
2684 /* Pointer functions can have stride[0] different from unity.
2685 Use the stride returned by the function call and stored in
2686 the descriptor for the temporary. */
2687 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2688 && se->ss->info->expr
2689 && se->ss->info->expr->symtree
2690 && se->ss->info->expr->symtree->n.sym->result
2691 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2692 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2695 if (!integer_zerop (info->delta[dim]))
2696 index = fold_build2_loc (input_location, PLUS_EXPR,
2697 gfc_array_index_type, index, info->delta[dim]);
2700 /* Multiply by the stride. */
2701 if (!integer_onep (stride))
2702 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2709 /* Build a scalarized reference to an array. */
2712 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2714 gfc_array_info *info;
2715 tree decl = NULL_TREE;
2723 expr = ss->info->expr;
2724 info = &ss->info->data.array;
2726 n = se->loop->order[0];
2730 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
2731 /* Add the offset for this dimension to the stored offset for all other
2733 if (!integer_zerop (info->offset))
2734 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2735 index, info->offset);
2737 if (expr && is_subref_array (expr))
2738 decl = expr->symtree->n.sym->backend_decl;
2740 tmp = build_fold_indirect_ref_loc (input_location, info->data);
2741 se->expr = gfc_build_array_ref (tmp, index, decl);
2745 /* Translate access of temporary array. */
2748 gfc_conv_tmp_array_ref (gfc_se * se)
2750 se->string_length = se->ss->info->string_length;
2751 gfc_conv_scalarized_array_ref (se, NULL);
2752 gfc_advance_se_ss_chain (se);
2755 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2758 add_to_offset (tree *cst_offset, tree *offset, tree t)
2760 if (TREE_CODE (t) == INTEGER_CST)
2761 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2764 if (!integer_zerop (*offset))
2765 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2766 gfc_array_index_type, *offset, t);
2772 /* Build an array reference. se->expr already holds the array descriptor.
2773 This should be either a variable, indirect variable reference or component
2774 reference. For arrays which do not have a descriptor, se->expr will be
2776 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2779 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2783 tree offset, cst_offset;
2791 gcc_assert (ar->codimen);
2793 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2794 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2797 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2798 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2799 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2801 /* Use the actual tree type and not the wrapped coarray. */
2802 if (!se->want_pointer)
2803 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2810 /* Handle scalarized references separately. */
2811 if (ar->type != AR_ELEMENT)
2813 gfc_conv_scalarized_array_ref (se, ar);
2814 gfc_advance_se_ss_chain (se);
2818 cst_offset = offset = gfc_index_zero_node;
2819 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2821 /* Calculate the offsets from all the dimensions. Make sure to associate
2822 the final offset so that we form a chain of loop invariant summands. */
2823 for (n = ar->dimen - 1; n >= 0; n--)
2825 /* Calculate the index for this dimension. */
2826 gfc_init_se (&indexse, se);
2827 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2828 gfc_add_block_to_block (&se->pre, &indexse.pre);
2830 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2832 /* Check array bounds. */
2836 /* Evaluate the indexse.expr only once. */
2837 indexse.expr = save_expr (indexse.expr);
2840 tmp = gfc_conv_array_lbound (se->expr, n);
2841 if (sym->attr.temporary)
2843 gfc_init_se (&tmpse, se);
2844 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2845 gfc_array_index_type);
2846 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2850 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2852 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2853 "below lower bound of %%ld", n+1, sym->name);
2854 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2855 fold_convert (long_integer_type_node,
2857 fold_convert (long_integer_type_node, tmp));
2860 /* Upper bound, but not for the last dimension of assumed-size
2862 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2864 tmp = gfc_conv_array_ubound (se->expr, n);
2865 if (sym->attr.temporary)
2867 gfc_init_se (&tmpse, se);
2868 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2869 gfc_array_index_type);
2870 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2874 cond = fold_build2_loc (input_location, GT_EXPR,
2875 boolean_type_node, indexse.expr, tmp);
2876 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2877 "above upper bound of %%ld", n+1, sym->name);
2878 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2879 fold_convert (long_integer_type_node,
2881 fold_convert (long_integer_type_node, tmp));
2886 /* Multiply the index by the stride. */
2887 stride = gfc_conv_array_stride (se->expr, n);
2888 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2889 indexse.expr, stride);
2891 /* And add it to the total. */
2892 add_to_offset (&cst_offset, &offset, tmp);
2895 if (!integer_zerop (cst_offset))
2896 offset = fold_build2_loc (input_location, PLUS_EXPR,
2897 gfc_array_index_type, offset, cst_offset);
2899 /* Access the calculated element. */
2900 tmp = gfc_conv_array_data (se->expr);
2901 tmp = build_fold_indirect_ref (tmp);
2902 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2906 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
2907 LOOP_DIM dimension (if any) to array's offset. */
2910 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
2911 gfc_array_ref *ar, int array_dim, int loop_dim)
2914 gfc_array_info *info;
2917 info = &ss->info->data.array;
2919 gfc_init_se (&se, NULL);
2921 se.expr = info->descriptor;
2922 stride = gfc_conv_array_stride (info->descriptor, array_dim);
2923 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
2924 gfc_add_block_to_block (pblock, &se.pre);
2926 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2927 gfc_array_index_type,
2928 info->offset, index);
2929 info->offset = gfc_evaluate_now (info->offset, pblock);
2933 /* Generate the code to be executed immediately before entering a
2934 scalarization loop. */
2937 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2938 stmtblock_t * pblock)
2941 gfc_ss_info *ss_info;
2942 gfc_array_info *info;
2943 gfc_ss_type ss_type;
2948 /* This code will be executed before entering the scalarization loop
2949 for this dimension. */
2950 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2954 if ((ss_info->useflags & flag) == 0)
2957 ss_type = ss_info->type;
2958 if (ss_type != GFC_SS_SECTION
2959 && ss_type != GFC_SS_FUNCTION
2960 && ss_type != GFC_SS_CONSTRUCTOR
2961 && ss_type != GFC_SS_COMPONENT)
2964 info = &ss_info->data.array;
2966 gcc_assert (dim < ss->dimen);
2967 gcc_assert (ss->dimen == loop->dimen);
2970 ar = &info->ref->u.ar;
2974 if (dim == loop->dimen - 1)
2979 /* For the time being, there is no loop reordering. */
2980 gcc_assert (i == loop->order[i]);
2983 if (dim == loop->dimen - 1)
2985 stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]);
2987 /* Calculate the stride of the innermost loop. Hopefully this will
2988 allow the backend optimizers to do their stuff more effectively.
2990 info->stride0 = gfc_evaluate_now (stride, pblock);
2992 /* For the outermost loop calculate the offset due to any
2993 elemental dimensions. It will have been initialized with the
2994 base offset of the array. */
2997 for (i = 0; i < ar->dimen; i++)
2999 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3002 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3007 /* Add the offset for the previous loop dimension. */
3008 add_array_offset (pblock, loop, ss, ar, ss->dim[i], i);
3010 /* Remember this offset for the second loop. */
3011 if (dim == loop->temp_dim - 1)
3012 info->saved_offset = info->offset;
3017 /* Start a scalarized expression. Creates a scope and declares loop
3021 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3027 gcc_assert (!loop->array_parameter);
3029 for (dim = loop->dimen - 1; dim >= 0; dim--)
3031 n = loop->order[dim];
3033 gfc_start_block (&loop->code[n]);
3035 /* Create the loop variable. */
3036 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3038 if (dim < loop->temp_dim)
3042 /* Calculate values that will be constant within this loop. */
3043 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3045 gfc_start_block (pbody);
3049 /* Generates the actual loop code for a scalarization loop. */
3052 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3053 stmtblock_t * pbody)
3064 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3065 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3066 && n == loop->dimen - 1)
3068 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3069 init = make_tree_vec (1);
3070 cond = make_tree_vec (1);
3071 incr = make_tree_vec (1);
3073 /* Cycle statement is implemented with a goto. Exit statement must not
3074 be present for this loop. */
3075 exit_label = gfc_build_label_decl (NULL_TREE);
3076 TREE_USED (exit_label) = 1;
3078 /* Label for cycle statements (if needed). */
3079 tmp = build1_v (LABEL_EXPR, exit_label);
3080 gfc_add_expr_to_block (pbody, tmp);
3082 stmt = make_node (OMP_FOR);
3084 TREE_TYPE (stmt) = void_type_node;
3085 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3087 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3088 OMP_CLAUSE_SCHEDULE);
3089 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3090 = OMP_CLAUSE_SCHEDULE_STATIC;
3091 if (ompws_flags & OMPWS_NOWAIT)
3092 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3093 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3095 /* Initialize the loopvar. */
3096 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3098 OMP_FOR_INIT (stmt) = init;
3099 /* The exit condition. */
3100 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3102 loop->loopvar[n], loop->to[n]);
3103 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3104 OMP_FOR_COND (stmt) = cond;
3105 /* Increment the loopvar. */
3106 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3107 loop->loopvar[n], gfc_index_one_node);
3108 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3109 void_type_node, loop->loopvar[n], tmp);
3110 OMP_FOR_INCR (stmt) = incr;
3112 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3113 gfc_add_expr_to_block (&loop->code[n], stmt);
3117 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3118 && (loop->temp_ss == NULL);
3120 loopbody = gfc_finish_block (pbody);
3124 tmp = loop->from[n];
3125 loop->from[n] = loop->to[n];
3129 /* Initialize the loopvar. */
3130 if (loop->loopvar[n] != loop->from[n])
3131 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3133 exit_label = gfc_build_label_decl (NULL_TREE);
3135 /* Generate the loop body. */
3136 gfc_init_block (&block);
3138 /* The exit condition. */
3139 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3140 boolean_type_node, loop->loopvar[n], loop->to[n]);
3141 tmp = build1_v (GOTO_EXPR, exit_label);
3142 TREE_USED (exit_label) = 1;
3143 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3144 gfc_add_expr_to_block (&block, tmp);
3146 /* The main body. */
3147 gfc_add_expr_to_block (&block, loopbody);
3149 /* Increment the loopvar. */
3150 tmp = fold_build2_loc (input_location,
3151 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3152 gfc_array_index_type, loop->loopvar[n],
3153 gfc_index_one_node);
3155 gfc_add_modify (&block, loop->loopvar[n], tmp);
3157 /* Build the loop. */
3158 tmp = gfc_finish_block (&block);
3159 tmp = build1_v (LOOP_EXPR, tmp);
3160 gfc_add_expr_to_block (&loop->code[n], tmp);
3162 /* Add the exit label. */
3163 tmp = build1_v (LABEL_EXPR, exit_label);
3164 gfc_add_expr_to_block (&loop->code[n], tmp);
3170 /* Finishes and generates the loops for a scalarized expression. */
3173 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3178 stmtblock_t *pblock;
3182 /* Generate the loops. */
3183 for (dim = 0; dim < loop->dimen; dim++)
3185 n = loop->order[dim];
3186 gfc_trans_scalarized_loop_end (loop, n, pblock);
3187 loop->loopvar[n] = NULL_TREE;
3188 pblock = &loop->code[n];
3191 tmp = gfc_finish_block (pblock);
3192 gfc_add_expr_to_block (&loop->pre, tmp);
3194 /* Clear all the used flags. */
3195 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3196 if (ss->parent == NULL)
3197 ss->info->useflags = 0;
3201 /* Finish the main body of a scalarized expression, and start the secondary
3205 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3209 stmtblock_t *pblock;
3213 /* We finish as many loops as are used by the temporary. */
3214 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3216 n = loop->order[dim];
3217 gfc_trans_scalarized_loop_end (loop, n, pblock);
3218 loop->loopvar[n] = NULL_TREE;
3219 pblock = &loop->code[n];
3222 /* We don't want to finish the outermost loop entirely. */
3223 n = loop->order[loop->temp_dim - 1];
3224 gfc_trans_scalarized_loop_end (loop, n, pblock);
3226 /* Restore the initial offsets. */
3227 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3229 gfc_ss_type ss_type;
3230 gfc_ss_info *ss_info;
3234 if ((ss_info->useflags & 2) == 0)
3237 ss_type = ss_info->type;
3238 if (ss_type != GFC_SS_SECTION
3239 && ss_type != GFC_SS_FUNCTION
3240 && ss_type != GFC_SS_CONSTRUCTOR
3241 && ss_type != GFC_SS_COMPONENT)
3244 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3247 /* Restart all the inner loops we just finished. */
3248 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3250 n = loop->order[dim];
3252 gfc_start_block (&loop->code[n]);
3254 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3256 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3259 /* Start a block for the secondary copying code. */
3260 gfc_start_block (body);
3264 /* Precalculate (either lower or upper) bound of an array section.
3265 BLOCK: Block in which the (pre)calculation code will go.
3266 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3267 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3268 DESC: Array descriptor from which the bound will be picked if unspecified
3269 (either lower or upper bound according to LBOUND). */
3272 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3273 tree desc, int dim, bool lbound)
3276 gfc_expr * input_val = values[dim];
3277 tree *output = &bounds[dim];
3282 /* Specified section bound. */
3283 gfc_init_se (&se, NULL);
3284 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3285 gfc_add_block_to_block (block, &se.pre);
3290 /* No specific bound specified so use the bound of the array. */
3291 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3292 gfc_conv_array_ubound (desc, dim);
3294 *output = gfc_evaluate_now (*output, block);
3298 /* Calculate the lower bound of an array section. */
3301 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3303 gfc_expr *stride = NULL;
3306 gfc_array_info *info;
3309 gcc_assert (ss->info->type == GFC_SS_SECTION);
3311 info = &ss->info->data.array;
3312 ar = &info->ref->u.ar;
3314 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3316 /* We use a zero-based index to access the vector. */
3317 info->start[dim] = gfc_index_zero_node;
3318 info->end[dim] = NULL;
3319 info->stride[dim] = gfc_index_one_node;
3323 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3324 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3325 desc = info->descriptor;
3326 stride = ar->stride[dim];
3328 /* Calculate the start of the range. For vector subscripts this will
3329 be the range of the vector. */
3330 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3332 /* Similarly calculate the end. Although this is not used in the
3333 scalarizer, it is needed when checking bounds and where the end
3334 is an expression with side-effects. */
3335 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3337 /* Calculate the stride. */
3339 info->stride[dim] = gfc_index_one_node;
3342 gfc_init_se (&se, NULL);
3343 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3344 gfc_add_block_to_block (&loop->pre, &se.pre);
3345 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3350 /* Calculates the range start and stride for a SS chain. Also gets the
3351 descriptor and data pointer. The range of vector subscripts is the size
3352 of the vector. Array bounds are also checked. */
3355 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3363 /* Determine the rank of the loop. */
3364 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3366 switch (ss->info->type)
3368 case GFC_SS_SECTION:
3369 case GFC_SS_CONSTRUCTOR:
3370 case GFC_SS_FUNCTION:
3371 case GFC_SS_COMPONENT:
3372 loop->dimen = ss->dimen;
3375 /* As usual, lbound and ubound are exceptions!. */
3376 case GFC_SS_INTRINSIC:
3377 switch (ss->info->expr->value.function.isym->id)
3379 case GFC_ISYM_LBOUND:
3380 case GFC_ISYM_UBOUND:
3381 case GFC_ISYM_LCOBOUND:
3382 case GFC_ISYM_UCOBOUND:
3383 case GFC_ISYM_THIS_IMAGE:
3384 loop->dimen = ss->dimen;
3396 /* We should have determined the rank of the expression by now. If
3397 not, that's bad news. */
3401 /* Loop over all the SS in the chain. */
3402 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3404 gfc_ss_info *ss_info;
3405 gfc_array_info *info;
3409 expr = ss_info->expr;
3410 info = &ss_info->data.array;
3412 if (expr && expr->shape && !info->shape)
3413 info->shape = expr->shape;
3415 switch (ss_info->type)
3417 case GFC_SS_SECTION:
3418 /* Get the descriptor for the array. */
3419 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3421 for (n = 0; n < ss->dimen; n++)
3422 gfc_conv_section_startstride (loop, ss, ss->dim[n]);
3425 case GFC_SS_INTRINSIC:
3426 switch (expr->value.function.isym->id)
3428 /* Fall through to supply start and stride. */
3429 case GFC_ISYM_LBOUND:
3430 case GFC_ISYM_UBOUND:
3431 case GFC_ISYM_LCOBOUND:
3432 case GFC_ISYM_UCOBOUND:
3433 case GFC_ISYM_THIS_IMAGE:
3440 case GFC_SS_CONSTRUCTOR:
3441 case GFC_SS_FUNCTION:
3442 for (n = 0; n < ss->dimen; n++)
3444 int dim = ss->dim[n];
3446 info->start[dim] = gfc_index_zero_node;
3447 info->end[dim] = gfc_index_zero_node;
3448 info->stride[dim] = gfc_index_one_node;
3457 /* The rest is just runtime bound checking. */
3458 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3461 tree lbound, ubound;
3463 tree size[GFC_MAX_DIMENSIONS];
3464 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3465 gfc_array_info *info;
3469 gfc_start_block (&block);
3471 for (n = 0; n < loop->dimen; n++)
3472 size[n] = NULL_TREE;
3474 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3477 gfc_ss_info *ss_info;
3480 const char *expr_name;
3483 if (ss_info->type != GFC_SS_SECTION)
3486 /* Catch allocatable lhs in f2003. */
3487 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3490 expr = ss_info->expr;
3491 expr_loc = &expr->where;
3492 expr_name = expr->symtree->name;
3494 gfc_start_block (&inner);
3496 /* TODO: range checking for mapped dimensions. */
3497 info = &ss_info->data.array;
3499 /* This code only checks ranges. Elemental and vector
3500 dimensions are checked later. */
3501 for (n = 0; n < loop->dimen; n++)
3506 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3509 if (dim == info->ref->u.ar.dimen - 1
3510 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3511 check_upper = false;
3515 /* Zero stride is not allowed. */
3516 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3517 info->stride[dim], gfc_index_zero_node);
3518 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3519 "of array '%s'", dim + 1, expr_name);
3520 gfc_trans_runtime_check (true, false, tmp, &inner,
3524 desc = info->descriptor;
3526 /* This is the run-time equivalent of resolve.c's
3527 check_dimension(). The logical is more readable there
3528 than it is here, with all the trees. */
3529 lbound = gfc_conv_array_lbound (desc, dim);
3530 end = info->end[dim];
3532 ubound = gfc_conv_array_ubound (desc, dim);
3536 /* non_zerosized is true when the selected range is not
3538 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3539 boolean_type_node, info->stride[dim],
3540 gfc_index_zero_node);
3541 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3542 info->start[dim], end);
3543 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3544 boolean_type_node, stride_pos, tmp);
3546 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3548 info->stride[dim], gfc_index_zero_node);
3549 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3550 info->start[dim], end);
3551 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3554 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3556 stride_pos, stride_neg);
3558 /* Check the start of the range against the lower and upper
3559 bounds of the array, if the range is not empty.
3560 If upper bound is present, include both bounds in the
3564 tmp = fold_build2_loc (input_location, LT_EXPR,
3566 info->start[dim], lbound);
3567 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3569 non_zerosized, tmp);
3570 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3572 info->start[dim], ubound);
3573 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3575 non_zerosized, tmp2);
3576 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3577 "outside of expected range (%%ld:%%ld)",
3578 dim + 1, expr_name);
3579 gfc_trans_runtime_check (true, false, tmp, &inner,
3581 fold_convert (long_integer_type_node, info->start[dim]),
3582 fold_convert (long_integer_type_node, lbound),
3583 fold_convert (long_integer_type_node, ubound));
3584 gfc_trans_runtime_check (true, false, tmp2, &inner,
3586 fold_convert (long_integer_type_node, info->start[dim]),
3587 fold_convert (long_integer_type_node, lbound),
3588 fold_convert (long_integer_type_node, ubound));
3593 tmp = fold_build2_loc (input_location, LT_EXPR,
3595 info->start[dim], lbound);
3596 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3597 boolean_type_node, non_zerosized, tmp);
3598 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3599 "below lower bound of %%ld",
3600 dim + 1, expr_name);
3601 gfc_trans_runtime_check (true, false, tmp, &inner,
3603 fold_convert (long_integer_type_node, info->start[dim]),
3604 fold_convert (long_integer_type_node, lbound));
3608 /* Compute the last element of the range, which is not
3609 necessarily "end" (think 0:5:3, which doesn't contain 5)
3610 and check it against both lower and upper bounds. */
3612 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3613 gfc_array_index_type, end,
3615 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3616 gfc_array_index_type, tmp,
3618 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3619 gfc_array_index_type, end, tmp);
3620 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3621 boolean_type_node, tmp, lbound);
3622 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3623 boolean_type_node, non_zerosized, tmp2);
3626 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3627 boolean_type_node, tmp, ubound);
3628 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3629 boolean_type_node, non_zerosized, tmp3);
3630 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3631 "outside of expected range (%%ld:%%ld)",
3632 dim + 1, expr_name);
3633 gfc_trans_runtime_check (true, false, tmp2, &inner,
3635 fold_convert (long_integer_type_node, tmp),
3636 fold_convert (long_integer_type_node, ubound),
3637 fold_convert (long_integer_type_node, lbound));
3638 gfc_trans_runtime_check (true, false, tmp3, &inner,
3640 fold_convert (long_integer_type_node, tmp),
3641 fold_convert (long_integer_type_node, ubound),
3642 fold_convert (long_integer_type_node, lbound));
3647 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3648 "below lower bound of %%ld",
3649 dim + 1, expr_name);
3650 gfc_trans_runtime_check (true, false, tmp2, &inner,
3652 fold_convert (long_integer_type_node, tmp),
3653 fold_convert (long_integer_type_node, lbound));
3657 /* Check the section sizes match. */
3658 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3659 gfc_array_index_type, end,
3661 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3662 gfc_array_index_type, tmp,
3664 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3665 gfc_array_index_type,
3666 gfc_index_one_node, tmp);
3667 tmp = fold_build2_loc (input_location, MAX_EXPR,
3668 gfc_array_index_type, tmp,
3669 build_int_cst (gfc_array_index_type, 0));
3670 /* We remember the size of the first section, and check all the
3671 others against this. */
3674 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3675 boolean_type_node, tmp, size[n]);
3676 asprintf (&msg, "Array bound mismatch for dimension %d "
3677 "of array '%s' (%%ld/%%ld)",
3678 dim + 1, expr_name);
3680 gfc_trans_runtime_check (true, false, tmp3, &inner,
3682 fold_convert (long_integer_type_node, tmp),
3683 fold_convert (long_integer_type_node, size[n]));
3688 size[n] = gfc_evaluate_now (tmp, &inner);
3691 tmp = gfc_finish_block (&inner);
3693 /* For optional arguments, only check bounds if the argument is
3695 if (expr->symtree->n.sym->attr.optional
3696 || expr->symtree->n.sym->attr.not_always_present)
3697 tmp = build3_v (COND_EXPR,
3698 gfc_conv_expr_present (expr->symtree->n.sym),
3699 tmp, build_empty_stmt (input_location));
3701 gfc_add_expr_to_block (&block, tmp);
3705 tmp = gfc_finish_block (&block);
3706 gfc_add_expr_to_block (&loop->pre, tmp);
3710 /* Return true if both symbols could refer to the same data object. Does
3711 not take account of aliasing due to equivalence statements. */
3714 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3715 bool lsym_target, bool rsym_pointer, bool rsym_target)
3717 /* Aliasing isn't possible if the symbols have different base types. */
3718 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3721 /* Pointers can point to other pointers and target objects. */
3723 if ((lsym_pointer && (rsym_pointer || rsym_target))
3724 || (rsym_pointer && (lsym_pointer || lsym_target)))
3727 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3728 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3730 if (lsym_target && rsym_target
3731 && ((lsym->attr.dummy && !lsym->attr.contiguous
3732 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3733 || (rsym->attr.dummy && !rsym->attr.contiguous
3734 && (!rsym->attr.dimension
3735 || rsym->as->type == AS_ASSUMED_SHAPE))))
3742 /* Return true if the two SS could be aliased, i.e. both point to the same data
3744 /* TODO: resolve aliases based on frontend expressions. */
3747 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3751 gfc_expr *lexpr, *rexpr;
3754 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3756 lexpr = lss->info->expr;
3757 rexpr = rss->info->expr;
3759 lsym = lexpr->symtree->n.sym;
3760 rsym = rexpr->symtree->n.sym;
3762 lsym_pointer = lsym->attr.pointer;
3763 lsym_target = lsym->attr.target;
3764 rsym_pointer = rsym->attr.pointer;
3765 rsym_target = rsym->attr.target;
3767 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3768 rsym_pointer, rsym_target))
3771 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3772 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3775 /* For derived types we must check all the component types. We can ignore
3776 array references as these will have the same base type as the previous
3778 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
3780 if (lref->type != REF_COMPONENT)
3783 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3784 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3786 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3787 rsym_pointer, rsym_target))
3790 if ((lsym_pointer && (rsym_pointer || rsym_target))
3791 || (rsym_pointer && (lsym_pointer || lsym_target)))
3793 if (gfc_compare_types (&lref->u.c.component->ts,
3798 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
3801 if (rref->type != REF_COMPONENT)
3804 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3805 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3807 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3808 lsym_pointer, lsym_target,
3809 rsym_pointer, rsym_target))
3812 if ((lsym_pointer && (rsym_pointer || rsym_target))
3813 || (rsym_pointer && (lsym_pointer || lsym_target)))
3815 if (gfc_compare_types (&lref->u.c.component->ts,
3816 &rref->u.c.sym->ts))
3818 if (gfc_compare_types (&lref->u.c.sym->ts,
3819 &rref->u.c.component->ts))
3821 if (gfc_compare_types (&lref->u.c.component->ts,
3822 &rref->u.c.component->ts))
3828 lsym_pointer = lsym->attr.pointer;
3829 lsym_target = lsym->attr.target;
3830 lsym_pointer = lsym->attr.pointer;
3831 lsym_target = lsym->attr.target;
3833 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
3835 if (rref->type != REF_COMPONENT)
3838 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3839 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3841 if (symbols_could_alias (rref->u.c.sym, lsym,
3842 lsym_pointer, lsym_target,
3843 rsym_pointer, rsym_target))
3846 if ((lsym_pointer && (rsym_pointer || rsym_target))
3847 || (rsym_pointer && (lsym_pointer || lsym_target)))
3849 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3858 /* Resolve array data dependencies. Creates a temporary if required. */
3859 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3863 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3869 gfc_expr *dest_expr;
3874 loop->temp_ss = NULL;
3875 dest_expr = dest->info->expr;
3877 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3879 if (ss->info->type != GFC_SS_SECTION)
3882 ss_expr = ss->info->expr;
3884 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
3886 if (gfc_could_be_alias (dest, ss)
3887 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
3895 lref = dest_expr->ref;
3896 rref = ss_expr->ref;
3898 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3903 for (i = 0; i < dest->dimen; i++)
3904 for (j = 0; j < ss->dimen; j++)
3906 && dest->dim[i] == ss->dim[j])
3908 /* If we don't access array elements in the same order,
3909 there is a dependency. */
3914 /* TODO : loop shifting. */
3917 /* Mark the dimensions for LOOP SHIFTING */
3918 for (n = 0; n < loop->dimen; n++)
3920 int dim = dest->data.info.dim[n];
3922 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3924 else if (! gfc_is_same_range (&lref->u.ar,
3925 &rref->u.ar, dim, 0))
3929 /* Put all the dimensions with dependencies in the
3932 for (n = 0; n < loop->dimen; n++)
3934 gcc_assert (loop->order[n] == n);
3936 loop->order[dim++] = n;
3938 for (n = 0; n < loop->dimen; n++)
3941 loop->order[dim++] = n;
3944 gcc_assert (dim == loop->dimen);
3955 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
3956 if (GFC_ARRAY_TYPE_P (base_type)
3957 || GFC_DESCRIPTOR_TYPE_P (base_type))
3958 base_type = gfc_get_element_type (base_type);
3959 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
3961 gfc_add_ss_to_loop (loop, loop->temp_ss);
3964 loop->temp_ss = NULL;
3968 /* Browse through each array's information from the scalarizer and set the loop
3969 bounds according to the "best" one (per dimension), i.e. the one which
3970 provides the most information (constant bounds, shape, etc). */
3973 set_loop_bounds (gfc_loopinfo *loop)
3975 int n, dim, spec_dim;
3976 gfc_array_info *info;
3977 gfc_array_info *specinfo;
3981 bool dynamic[GFC_MAX_DIMENSIONS];
3985 loopspec = loop->specloop;
3988 for (n = 0; n < loop->dimen; n++)
3992 /* We use one SS term, and use that to determine the bounds of the
3993 loop for this dimension. We try to pick the simplest term. */
3994 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3996 gfc_ss_type ss_type;
3998 ss_type = ss->info->type;
3999 if (ss_type == GFC_SS_SCALAR
4000 || ss_type == GFC_SS_TEMP
4001 || ss_type == GFC_SS_REFERENCE)
4004 info = &ss->info->data.array;
4007 if (loopspec[n] != NULL)
4009 specinfo = &loopspec[n]->info->data.array;
4010 spec_dim = loopspec[n]->dim[n];
4014 /* Silence unitialized warnings. */
4021 gcc_assert (info->shape[dim]);
4022 /* The frontend has worked out the size for us. */
4025 || !integer_zerop (specinfo->start[spec_dim]))
4026 /* Prefer zero-based descriptors if possible. */
4031 if (ss_type == GFC_SS_CONSTRUCTOR)
4033 gfc_constructor_base base;
4034 /* An unknown size constructor will always be rank one.
4035 Higher rank constructors will either have known shape,
4036 or still be wrapped in a call to reshape. */
4037 gcc_assert (loop->dimen == 1);
4039 /* Always prefer to use the constructor bounds if the size
4040 can be determined at compile time. Prefer not to otherwise,
4041 since the general case involves realloc, and it's better to
4042 avoid that overhead if possible. */
4043 base = ss->info->expr->value.constructor;
4044 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4045 if (!dynamic[n] || !loopspec[n])
4050 /* TODO: Pick the best bound if we have a choice between a
4051 function and something else. */
4052 if (ss_type == GFC_SS_FUNCTION)
4058 /* Avoid using an allocatable lhs in an assignment, since
4059 there might be a reallocation coming. */
4060 if (loopspec[n] && ss->is_alloc_lhs)
4063 if (ss_type != GFC_SS_SECTION)
4068 /* Criteria for choosing a loop specifier (most important first):
4069 doesn't need realloc
4075 else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4076 || n >= loop->dimen)
4078 else if (integer_onep (info->stride[dim])
4079 && !integer_onep (specinfo->stride[spec_dim]))
4081 else if (INTEGER_CST_P (info->stride[dim])
4082 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4084 else if (INTEGER_CST_P (info->start[dim])
4085 && !INTEGER_CST_P (specinfo->start[spec_dim]))
4087 /* We don't work out the upper bound.
4088 else if (INTEGER_CST_P (info->finish[n])
4089 && ! INTEGER_CST_P (specinfo->finish[n]))
4090 loopspec[n] = ss; */
4093 /* We should have found the scalarization loop specifier. If not,
4095 gcc_assert (loopspec[n]);
4097 info = &loopspec[n]->info->data.array;
4098 dim = loopspec[n]->dim[n];
4100 /* Set the extents of this range. */
4101 cshape = info->shape;
4102 if (cshape && INTEGER_CST_P (info->start[dim])
4103 && INTEGER_CST_P (info->stride[dim]))
4105 loop->from[n] = info->start[dim];
4106 mpz_set (i, cshape[get_array_ref_dim (loopspec[n], n)]);
4107 mpz_sub_ui (i, i, 1);
4108 /* To = from + (size - 1) * stride. */
4109 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4110 if (!integer_onep (info->stride[dim]))
4111 tmp = fold_build2_loc (input_location, MULT_EXPR,
4112 gfc_array_index_type, tmp,
4114 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4115 gfc_array_index_type,
4116 loop->from[n], tmp);
4120 loop->from[n] = info->start[dim];
4121 switch (loopspec[n]->info->type)
4123 case GFC_SS_CONSTRUCTOR:
4124 /* The upper bound is calculated when we expand the
4126 gcc_assert (loop->to[n] == NULL_TREE);
4129 case GFC_SS_SECTION:
4130 /* Use the end expression if it exists and is not constant,
4131 so that it is only evaluated once. */
4132 loop->to[n] = info->end[dim];
4135 case GFC_SS_FUNCTION:
4136 /* The loop bound will be set when we generate the call. */
4137 gcc_assert (loop->to[n] == NULL_TREE);
4145 /* Transform everything so we have a simple incrementing variable. */
4146 if (n < loop->dimen && integer_onep (info->stride[dim]))
4147 info->delta[dim] = gfc_index_zero_node;
4148 else if (n < loop->dimen)
4150 /* Set the delta for this section. */
4151 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4152 /* Number of iterations is (end - start + step) / step.
4153 with start = 0, this simplifies to
4155 for (i = 0; i<=last; i++){...}; */
4156 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4157 gfc_array_index_type, loop->to[n],
4159 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4160 gfc_array_index_type, tmp, info->stride[dim]);
4161 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4162 tmp, build_int_cst (gfc_array_index_type, -1));
4163 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4164 /* Make the loop variable start at 0. */
4165 loop->from[n] = gfc_index_zero_node;
4172 static void set_delta (gfc_loopinfo *loop);
4175 /* Initialize the scalarization loop. Creates the loop variables. Determines
4176 the range of the loop variables. Creates a temporary if required.
4177 Also generates code for scalar expressions which have been
4178 moved outside the loop. */
4181 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4186 set_loop_bounds (loop);
4188 /* Add all the scalar code that can be taken out of the loops.
4189 This may include calculating the loop bounds, so do it before
4190 allocating the temporary. */
4191 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4193 tmp_ss = loop->temp_ss;
4194 /* If we want a temporary then create it. */
4197 gfc_ss_info *tmp_ss_info;
4199 tmp_ss_info = tmp_ss->info;
4200 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4202 /* Make absolutely sure that this is a complete type. */
4203 if (tmp_ss_info->string_length)
4204 tmp_ss_info->data.temp.type
4205 = gfc_get_character_type_len_for_eltype
4206 (TREE_TYPE (tmp_ss_info->data.temp.type),
4207 tmp_ss_info->string_length);
4209 tmp = tmp_ss_info->data.temp.type;
4210 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4211 tmp_ss_info->type = GFC_SS_SECTION;
4213 gcc_assert (tmp_ss->dimen != 0);
4215 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4216 NULL_TREE, false, true, false, where);
4219 /* For array parameters we don't have loop variables, so don't calculate the
4221 if (loop->array_parameter)
4228 /* Calculates how to transform from loop variables to array indices for each
4229 array: once loop bounds are chosen, sets the difference (DELTA field) between
4230 loop bounds and array reference bounds, for each array info. */
4233 set_delta (gfc_loopinfo *loop)
4235 gfc_ss *ss, **loopspec;
4236 gfc_array_info *info;
4240 loopspec = loop->specloop;
4242 /* Calculate the translation from loop variables to array indices. */
4243 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4245 gfc_ss_type ss_type;
4247 ss_type = ss->info->type;
4248 if (ss_type != GFC_SS_SECTION
4249 && ss_type != GFC_SS_COMPONENT
4250 && ss_type != GFC_SS_CONSTRUCTOR)
4253 info = &ss->info->data.array;
4255 for (n = 0; n < ss->dimen; n++)
4257 /* If we are specifying the range the delta is already set. */
4258 if (loopspec[n] != ss)
4262 /* Calculate the offset relative to the loop variable.
4263 First multiply by the stride. */
4264 tmp = loop->from[n];
4265 if (!integer_onep (info->stride[dim]))
4266 tmp = fold_build2_loc (input_location, MULT_EXPR,
4267 gfc_array_index_type,
4268 tmp, info->stride[dim]);
4270 /* Then subtract this from our starting value. */
4271 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4272 gfc_array_index_type,
4273 info->start[dim], tmp);
4275 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4282 /* Calculate the size of a given array dimension from the bounds. This
4283 is simply (ubound - lbound + 1) if this expression is positive
4284 or 0 if it is negative (pick either one if it is zero). Optionally
4285 (if or_expr is present) OR the (expression != 0) condition to it. */
4288 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4293 /* Calculate (ubound - lbound + 1). */
4294 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4296 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4297 gfc_index_one_node);
4299 /* Check whether the size for this dimension is negative. */
4300 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4301 gfc_index_zero_node);
4302 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4303 gfc_index_zero_node, res);
4305 /* Build OR expression. */
4307 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4308 boolean_type_node, *or_expr, cond);
4314 /* For an array descriptor, get the total number of elements. This is just
4315 the product of the extents along from_dim to to_dim. */
4318 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4323 res = gfc_index_one_node;
4325 for (dim = from_dim; dim < to_dim; ++dim)
4331 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4332 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4334 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4335 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4343 /* Full size of an array. */
4346 gfc_conv_descriptor_size (tree desc, int rank)
4348 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4352 /* Size of a coarray for all dimensions but the last. */
4355 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4357 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4361 /* Fills in an array descriptor, and returns the size of the array.
4362 The size will be a simple_val, ie a variable or a constant. Also
4363 calculates the offset of the base. The pointer argument overflow,
4364 which should be of integer type, will increase in value if overflow
4365 occurs during the size calculation. Returns the size of the array.
4369 for (n = 0; n < rank; n++)
4371 a.lbound[n] = specified_lower_bound;
4372 offset = offset + a.lbond[n] * stride;
4374 a.ubound[n] = specified_upper_bound;
4375 a.stride[n] = stride;
4376 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4377 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4378 stride = stride * size;
4380 for (n = rank; n < rank+corank; n++)
4381 (Set lcobound/ucobound as above.)
4382 element_size = sizeof (array element);
4385 stride = (size_t) stride;
4386 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4387 stride = stride * element_size;
4393 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4394 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4395 stmtblock_t * descriptor_block, tree * overflow)
4408 stmtblock_t thenblock;
4409 stmtblock_t elseblock;
4414 type = TREE_TYPE (descriptor);
4416 stride = gfc_index_one_node;
4417 offset = gfc_index_zero_node;
4419 /* Set the dtype. */
4420 tmp = gfc_conv_descriptor_dtype (descriptor);
4421 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4423 or_expr = boolean_false_node;
4425 for (n = 0; n < rank; n++)
4430 /* We have 3 possibilities for determining the size of the array:
4431 lower == NULL => lbound = 1, ubound = upper[n]
4432 upper[n] = NULL => lbound = 1, ubound = lower[n]
4433 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4436 /* Set lower bound. */
4437 gfc_init_se (&se, NULL);
4439 se.expr = gfc_index_one_node;
4442 gcc_assert (lower[n]);
4445 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4446 gfc_add_block_to_block (pblock, &se.pre);
4450 se.expr = gfc_index_one_node;
4454 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4455 gfc_rank_cst[n], se.expr);
4456 conv_lbound = se.expr;
4458 /* Work out the offset for this component. */
4459 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4461 offset = fold_build2_loc (input_location, MINUS_EXPR,
4462 gfc_array_index_type, offset, tmp);
4464 /* Set upper bound. */
4465 gfc_init_se (&se, NULL);
4466 gcc_assert (ubound);
4467 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4468 gfc_add_block_to_block (pblock, &se.pre);
4470 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4471 gfc_rank_cst[n], se.expr);
4472 conv_ubound = se.expr;
4474 /* Store the stride. */
4475 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4476 gfc_rank_cst[n], stride);
4478 /* Calculate size and check whether extent is negative. */
4479 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4480 size = gfc_evaluate_now (size, pblock);
4482 /* Check whether multiplying the stride by the number of
4483 elements in this dimension would overflow. We must also check
4484 whether the current dimension has zero size in order to avoid
4487 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4488 gfc_array_index_type,
4489 fold_convert (gfc_array_index_type,
4490 TYPE_MAX_VALUE (gfc_array_index_type)),
4492 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4493 boolean_type_node, tmp, stride));
4494 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4495 integer_one_node, integer_zero_node);
4496 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4497 boolean_type_node, size,
4498 gfc_index_zero_node));
4499 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4500 integer_zero_node, tmp);
4501 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4503 *overflow = gfc_evaluate_now (tmp, pblock);
4505 /* Multiply the stride by the number of elements in this dimension. */
4506 stride = fold_build2_loc (input_location, MULT_EXPR,
4507 gfc_array_index_type, stride, size);
4508 stride = gfc_evaluate_now (stride, pblock);
4511 for (n = rank; n < rank + corank; n++)
4515 /* Set lower bound. */
4516 gfc_init_se (&se, NULL);
4517 if (lower == NULL || lower[n] == NULL)
4519 gcc_assert (n == rank + corank - 1);
4520 se.expr = gfc_index_one_node;
4524 if (ubound || n == rank + corank - 1)
4526 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4527 gfc_add_block_to_block (pblock, &se.pre);
4531 se.expr = gfc_index_one_node;
4535 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4536 gfc_rank_cst[n], se.expr);
4538 if (n < rank + corank - 1)
4540 gfc_init_se (&se, NULL);
4541 gcc_assert (ubound);
4542 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4543 gfc_add_block_to_block (pblock, &se.pre);
4544 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4545 gfc_rank_cst[n], se.expr);
4549 /* The stride is the number of elements in the array, so multiply by the
4550 size of an element to get the total size. */
4551 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4552 /* Convert to size_t. */
4553 element_size = fold_convert (size_type_node, tmp);
4556 return element_size;
4558 stride = fold_convert (size_type_node, stride);
4560 /* First check for overflow. Since an array of type character can
4561 have zero element_size, we must check for that before
4563 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4565 TYPE_MAX_VALUE (size_type_node), element_size);
4566 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4567 boolean_type_node, tmp, stride));
4568 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4569 integer_one_node, integer_zero_node);
4570 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4571 boolean_type_node, element_size,
4572 build_int_cst (size_type_node, 0)));
4573 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4574 integer_zero_node, tmp);
4575 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4577 *overflow = gfc_evaluate_now (tmp, pblock);
4579 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4580 stride, element_size);
4582 if (poffset != NULL)
4584 offset = gfc_evaluate_now (offset, pblock);
4588 if (integer_zerop (or_expr))
4590 if (integer_onep (or_expr))
4591 return build_int_cst (size_type_node, 0);
4593 var = gfc_create_var (TREE_TYPE (size), "size");
4594 gfc_start_block (&thenblock);
4595 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4596 thencase = gfc_finish_block (&thenblock);
4598 gfc_start_block (&elseblock);
4599 gfc_add_modify (&elseblock, var, size);
4600 elsecase = gfc_finish_block (&elseblock);
4602 tmp = gfc_evaluate_now (or_expr, pblock);
4603 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4604 gfc_add_expr_to_block (pblock, tmp);
4610 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4611 the work for an ALLOCATE statement. */
4615 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4620 tree offset = NULL_TREE;
4621 tree token = NULL_TREE;
4624 tree error = NULL_TREE;
4625 tree overflow; /* Boolean storing whether size calculation overflows. */
4626 tree var_overflow = NULL_TREE;
4628 tree set_descriptor;
4629 stmtblock_t set_descriptor_block;
4630 stmtblock_t elseblock;
4633 gfc_ref *ref, *prev_ref = NULL;
4634 bool allocatable, coarray, dimension;
4638 /* Find the last reference in the chain. */
4639 while (ref && ref->next != NULL)
4641 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4642 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4647 if (ref == NULL || ref->type != REF_ARRAY)
4652 allocatable = expr->symtree->n.sym->attr.allocatable;
4653 coarray = expr->symtree->n.sym->attr.codimension;
4654 dimension = expr->symtree->n.sym->attr.dimension;
4658 allocatable = prev_ref->u.c.component->attr.allocatable;
4659 coarray = prev_ref->u.c.component->attr.codimension;
4660 dimension = prev_ref->u.c.component->attr.dimension;
4664 gcc_assert (coarray);
4666 /* Figure out the size of the array. */
4667 switch (ref->u.ar.type)
4673 upper = ref->u.ar.start;
4679 lower = ref->u.ar.start;
4680 upper = ref->u.ar.end;
4684 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4686 lower = ref->u.ar.as->lower;
4687 upper = ref->u.ar.as->upper;
4695 overflow = integer_zero_node;
4697 gfc_init_block (&set_descriptor_block);
4698 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4699 ref->u.ar.as->corank, &offset, lower, upper,
4700 &se->pre, &set_descriptor_block, &overflow);
4705 var_overflow = gfc_create_var (integer_type_node, "overflow");
4706 gfc_add_modify (&se->pre, var_overflow, overflow);
4708 /* Generate the block of code handling overflow. */
4709 msg = gfc_build_addr_expr (pchar_type_node,
4710 gfc_build_localized_cstring_const
4711 ("Integer overflow when calculating the amount of "
4712 "memory to allocate"));
4713 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4717 if (status != NULL_TREE)
4719 tree status_type = TREE_TYPE (status);
4720 stmtblock_t set_status_block;
4722 gfc_start_block (&set_status_block);
4723 gfc_add_modify (&set_status_block, status,
4724 build_int_cst (status_type, LIBERROR_ALLOCATION));
4725 error = gfc_finish_block (&set_status_block);
4728 gfc_start_block (&elseblock);
4730 /* Allocate memory to store the data. */
4731 pointer = gfc_conv_descriptor_data_get (se->expr);
4732 STRIP_NOPS (pointer);
4734 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4735 token = gfc_build_addr_expr (NULL_TREE,
4736 gfc_conv_descriptor_token (se->expr));
4738 /* The allocatable variant takes the old pointer as first argument. */
4740 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4741 status, errmsg, errlen, expr);
4743 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4747 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4748 boolean_type_node, var_overflow, integer_zero_node));
4749 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4750 error, gfc_finish_block (&elseblock));
4753 tmp = gfc_finish_block (&elseblock);
4755 gfc_add_expr_to_block (&se->pre, tmp);
4757 /* Update the array descriptors. */
4759 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4761 set_descriptor = gfc_finish_block (&set_descriptor_block);
4762 if (status != NULL_TREE)
4764 cond = fold_build2_loc (input_location, EQ_EXPR,
4765 boolean_type_node, status,
4766 build_int_cst (TREE_TYPE (status), 0));
4767 gfc_add_expr_to_block (&se->pre,
4768 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4769 gfc_likely (cond), set_descriptor,
4770 build_empty_stmt (input_location)));
4773 gfc_add_expr_to_block (&se->pre, set_descriptor);
4775 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4776 && expr->ts.u.derived->attr.alloc_comp)
4778 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4779 ref->u.ar.as->rank);
4780 gfc_add_expr_to_block (&se->pre, tmp);
4787 /* Deallocate an array variable. Also used when an allocated variable goes
4792 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4798 gfc_start_block (&block);
4799 /* Get a pointer to the data. */
4800 var = gfc_conv_descriptor_data_get (descriptor);
4803 /* Parameter is the address of the data component. */
4804 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4805 gfc_add_expr_to_block (&block, tmp);
4807 /* Zero the data pointer. */
4808 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4809 var, build_int_cst (TREE_TYPE (var), 0));
4810 gfc_add_expr_to_block (&block, tmp);
4812 return gfc_finish_block (&block);
4816 /* Create an array constructor from an initialization expression.
4817 We assume the frontend already did any expansions and conversions. */
4820 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4826 unsigned HOST_WIDE_INT lo;
4828 VEC(constructor_elt,gc) *v = NULL;
4830 switch (expr->expr_type)
4833 case EXPR_STRUCTURE:
4834 /* A single scalar or derived type value. Create an array with all
4835 elements equal to that value. */
4836 gfc_init_se (&se, NULL);
4838 if (expr->expr_type == EXPR_CONSTANT)
4839 gfc_conv_constant (&se, expr);
4841 gfc_conv_structure (&se, expr, 1);
4843 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4844 gcc_assert (tmp && INTEGER_CST_P (tmp));
4845 hi = TREE_INT_CST_HIGH (tmp);
4846 lo = TREE_INT_CST_LOW (tmp);
4850 /* This will probably eat buckets of memory for large arrays. */
4851 while (hi != 0 || lo != 0)
4853 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4861 /* Create a vector of all the elements. */
4862 for (c = gfc_constructor_first (expr->value.constructor);
4863 c; c = gfc_constructor_next (c))
4867 /* Problems occur when we get something like
4868 integer :: a(lots) = (/(i, i=1, lots)/) */
4869 gfc_fatal_error ("The number of elements in the array constructor "
4870 "at %L requires an increase of the allowed %d "
4871 "upper limit. See -fmax-array-constructor "
4872 "option", &expr->where,
4873 gfc_option.flag_max_array_constructor);
4876 if (mpz_cmp_si (c->offset, 0) != 0)
4877 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4881 if (mpz_cmp_si (c->repeat, 1) > 0)
4887 mpz_add (maxval, c->offset, c->repeat);
4888 mpz_sub_ui (maxval, maxval, 1);
4889 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4890 if (mpz_cmp_si (c->offset, 0) != 0)
4892 mpz_add_ui (maxval, c->offset, 1);
4893 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4896 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4898 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4904 gfc_init_se (&se, NULL);
4905 switch (c->expr->expr_type)
4908 gfc_conv_constant (&se, c->expr);
4911 case EXPR_STRUCTURE:
4912 gfc_conv_structure (&se, c->expr, 1);
4916 /* Catch those occasional beasts that do not simplify
4917 for one reason or another, assuming that if they are
4918 standard defying the frontend will catch them. */
4919 gfc_conv_expr (&se, c->expr);
4923 if (range == NULL_TREE)
4924 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4927 if (index != NULL_TREE)
4928 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4929 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4935 return gfc_build_null_descriptor (type);
4941 /* Create a constructor from the list of elements. */
4942 tmp = build_constructor (type, v);
4943 TREE_CONSTANT (tmp) = 1;
4948 /* Generate code to evaluate non-constant coarray cobounds. */
4951 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4952 const gfc_symbol *sym)
4962 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4964 /* Evaluate non-constant array bound expressions. */
4965 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4966 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4968 gfc_init_se (&se, NULL);
4969 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4970 gfc_add_block_to_block (pblock, &se.pre);
4971 gfc_add_modify (pblock, lbound, se.expr);
4973 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4974 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4976 gfc_init_se (&se, NULL);
4977 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4978 gfc_add_block_to_block (pblock, &se.pre);
4979 gfc_add_modify (pblock, ubound, se.expr);
4985 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4986 returns the size (in elements) of the array. */
4989 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4990 stmtblock_t * pblock)
5005 size = gfc_index_one_node;
5006 offset = gfc_index_zero_node;
5007 for (dim = 0; dim < as->rank; dim++)
5009 /* Evaluate non-constant array bound expressions. */
5010 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5011 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5013 gfc_init_se (&se, NULL);
5014 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5015 gfc_add_block_to_block (pblock, &se.pre);
5016 gfc_add_modify (pblock, lbound, se.expr);
5018 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5019 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5021 gfc_init_se (&se, NULL);
5022 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5023 gfc_add_block_to_block (pblock, &se.pre);
5024 gfc_add_modify (pblock, ubound, se.expr);
5026 /* The offset of this dimension. offset = offset - lbound * stride. */
5027 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5029 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5032 /* The size of this dimension, and the stride of the next. */
5033 if (dim + 1 < as->rank)
5034 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5036 stride = GFC_TYPE_ARRAY_SIZE (type);
5038 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5040 /* Calculate stride = size * (ubound + 1 - lbound). */
5041 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5042 gfc_array_index_type,
5043 gfc_index_one_node, lbound);
5044 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5045 gfc_array_index_type, ubound, tmp);
5046 tmp = fold_build2_loc (input_location, MULT_EXPR,
5047 gfc_array_index_type, size, tmp);
5049 gfc_add_modify (pblock, stride, tmp);
5051 stride = gfc_evaluate_now (tmp, pblock);
5053 /* Make sure that negative size arrays are translated
5054 to being zero size. */
5055 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5056 stride, gfc_index_zero_node);
5057 tmp = fold_build3_loc (input_location, COND_EXPR,
5058 gfc_array_index_type, tmp,
5059 stride, gfc_index_zero_node);
5060 gfc_add_modify (pblock, stride, tmp);
5066 gfc_trans_array_cobounds (type, pblock, sym);
5067 gfc_trans_vla_type_sizes (sym, pblock);
5074 /* Generate code to initialize/allocate an array variable. */
5077 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5078 gfc_wrapped_block * block)
5082 tree tmp = NULL_TREE;
5089 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5091 /* Do nothing for USEd variables. */
5092 if (sym->attr.use_assoc)
5095 type = TREE_TYPE (decl);
5096 gcc_assert (GFC_ARRAY_TYPE_P (type));
5097 onstack = TREE_CODE (type) != POINTER_TYPE;
5099 gfc_init_block (&init);
5101 /* Evaluate character string length. */
5102 if (sym->ts.type == BT_CHARACTER
5103 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5105 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5107 gfc_trans_vla_type_sizes (sym, &init);
5109 /* Emit a DECL_EXPR for this variable, which will cause the
5110 gimplifier to allocate storage, and all that good stuff. */
5111 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5112 gfc_add_expr_to_block (&init, tmp);
5117 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5121 type = TREE_TYPE (type);
5123 gcc_assert (!sym->attr.use_assoc);
5124 gcc_assert (!TREE_STATIC (decl));
5125 gcc_assert (!sym->module);
5127 if (sym->ts.type == BT_CHARACTER
5128 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5129 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5131 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5133 /* Don't actually allocate space for Cray Pointees. */
5134 if (sym->attr.cray_pointee)
5136 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5137 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5139 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5143 if (gfc_option.flag_stack_arrays)
5145 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5146 space = build_decl (sym->declared_at.lb->location,
5147 VAR_DECL, create_tmp_var_name ("A"),
5148 TREE_TYPE (TREE_TYPE (decl)));
5149 gfc_trans_vla_type_sizes (sym, &init);
5153 /* The size is the number of elements in the array, so multiply by the
5154 size of an element to get the total size. */
5155 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5156 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5157 size, fold_convert (gfc_array_index_type, tmp));
5159 /* Allocate memory to hold the data. */
5160 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5161 gfc_add_modify (&init, decl, tmp);
5163 /* Free the temporary. */
5164 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5168 /* Set offset of the array. */
5169 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5170 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5172 /* Automatic arrays should not have initializers. */
5173 gcc_assert (!sym->value);
5175 inittree = gfc_finish_block (&init);
5182 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5183 where also space is located. */
5184 gfc_init_block (&init);
5185 tmp = fold_build1_loc (input_location, DECL_EXPR,
5186 TREE_TYPE (space), space);
5187 gfc_add_expr_to_block (&init, tmp);
5188 addr = fold_build1_loc (sym->declared_at.lb->location,
5189 ADDR_EXPR, TREE_TYPE (decl), space);
5190 gfc_add_modify (&init, decl, addr);
5191 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5194 gfc_add_init_cleanup (block, inittree, tmp);
5198 /* Generate entry and exit code for g77 calling convention arrays. */
5201 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5211 gfc_save_backend_locus (&loc);
5212 gfc_set_backend_locus (&sym->declared_at);
5214 /* Descriptor type. */
5215 parm = sym->backend_decl;
5216 type = TREE_TYPE (parm);
5217 gcc_assert (GFC_ARRAY_TYPE_P (type));
5219 gfc_start_block (&init);
5221 if (sym->ts.type == BT_CHARACTER
5222 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5223 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5225 /* Evaluate the bounds of the array. */
5226 gfc_trans_array_bounds (type, sym, &offset, &init);
5228 /* Set the offset. */
5229 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5230 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5232 /* Set the pointer itself if we aren't using the parameter directly. */
5233 if (TREE_CODE (parm) != PARM_DECL)
5235 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5236 gfc_add_modify (&init, parm, tmp);
5238 stmt = gfc_finish_block (&init);
5240 gfc_restore_backend_locus (&loc);
5242 /* Add the initialization code to the start of the function. */
5244 if (sym->attr.optional || sym->attr.not_always_present)
5246 tmp = gfc_conv_expr_present (sym);
5247 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5250 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5254 /* Modify the descriptor of an array parameter so that it has the
5255 correct lower bound. Also move the upper bound accordingly.
5256 If the array is not packed, it will be copied into a temporary.
5257 For each dimension we set the new lower and upper bounds. Then we copy the
5258 stride and calculate the offset for this dimension. We also work out
5259 what the stride of a packed array would be, and see it the two match.
5260 If the array need repacking, we set the stride to the values we just
5261 calculated, recalculate the offset and copy the array data.
5262 Code is also added to copy the data back at the end of the function.
5266 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5267 gfc_wrapped_block * block)
5274 tree stmtInit, stmtCleanup;
5281 tree stride, stride2;
5291 /* Do nothing for pointer and allocatable arrays. */
5292 if (sym->attr.pointer || sym->attr.allocatable)
5295 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5297 gfc_trans_g77_array (sym, block);
5301 gfc_save_backend_locus (&loc);
5302 gfc_set_backend_locus (&sym->declared_at);
5304 /* Descriptor type. */
5305 type = TREE_TYPE (tmpdesc);
5306 gcc_assert (GFC_ARRAY_TYPE_P (type));
5307 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5308 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5309 gfc_start_block (&init);
5311 if (sym->ts.type == BT_CHARACTER
5312 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5313 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5315 checkparm = (sym->as->type == AS_EXPLICIT
5316 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5318 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5319 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5321 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5323 /* For non-constant shape arrays we only check if the first dimension
5324 is contiguous. Repacking higher dimensions wouldn't gain us
5325 anything as we still don't know the array stride. */
5326 partial = gfc_create_var (boolean_type_node, "partial");
5327 TREE_USED (partial) = 1;
5328 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5329 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5330 gfc_index_one_node);
5331 gfc_add_modify (&init, partial, tmp);
5334 partial = NULL_TREE;
5336 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5337 here, however I think it does the right thing. */
5340 /* Set the first stride. */
5341 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5342 stride = gfc_evaluate_now (stride, &init);
5344 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5345 stride, gfc_index_zero_node);
5346 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5347 tmp, gfc_index_one_node, stride);
5348 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5349 gfc_add_modify (&init, stride, tmp);
5351 /* Allow the user to disable array repacking. */
5352 stmt_unpacked = NULL_TREE;
5356 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5357 /* A library call to repack the array if necessary. */
5358 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5359 stmt_unpacked = build_call_expr_loc (input_location,
5360 gfor_fndecl_in_pack, 1, tmp);
5362 stride = gfc_index_one_node;
5364 if (gfc_option.warn_array_temp)
5365 gfc_warning ("Creating array temporary at %L", &loc);
5368 /* This is for the case where the array data is used directly without
5369 calling the repack function. */
5370 if (no_repack || partial != NULL_TREE)
5371 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5373 stmt_packed = NULL_TREE;
5375 /* Assign the data pointer. */
5376 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5378 /* Don't repack unknown shape arrays when the first stride is 1. */
5379 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5380 partial, stmt_packed, stmt_unpacked);
5383 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5384 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5386 offset = gfc_index_zero_node;
5387 size = gfc_index_one_node;
5389 /* Evaluate the bounds of the array. */
5390 for (n = 0; n < sym->as->rank; n++)
5392 if (checkparm || !sym->as->upper[n])
5394 /* Get the bounds of the actual parameter. */
5395 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5396 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5400 dubound = NULL_TREE;
5401 dlbound = NULL_TREE;
5404 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5405 if (!INTEGER_CST_P (lbound))
5407 gfc_init_se (&se, NULL);
5408 gfc_conv_expr_type (&se, sym->as->lower[n],
5409 gfc_array_index_type);
5410 gfc_add_block_to_block (&init, &se.pre);
5411 gfc_add_modify (&init, lbound, se.expr);
5414 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5415 /* Set the desired upper bound. */
5416 if (sym->as->upper[n])
5418 /* We know what we want the upper bound to be. */
5419 if (!INTEGER_CST_P (ubound))
5421 gfc_init_se (&se, NULL);
5422 gfc_conv_expr_type (&se, sym->as->upper[n],
5423 gfc_array_index_type);
5424 gfc_add_block_to_block (&init, &se.pre);
5425 gfc_add_modify (&init, ubound, se.expr);
5428 /* Check the sizes match. */
5431 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5435 temp = fold_build2_loc (input_location, MINUS_EXPR,
5436 gfc_array_index_type, ubound, lbound);
5437 temp = fold_build2_loc (input_location, PLUS_EXPR,
5438 gfc_array_index_type,
5439 gfc_index_one_node, temp);
5440 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5441 gfc_array_index_type, dubound,
5443 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5444 gfc_array_index_type,
5445 gfc_index_one_node, stride2);
5446 tmp = fold_build2_loc (input_location, NE_EXPR,
5447 gfc_array_index_type, temp, stride2);
5448 asprintf (&msg, "Dimension %d of array '%s' has extent "
5449 "%%ld instead of %%ld", n+1, sym->name);
5451 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5452 fold_convert (long_integer_type_node, temp),
5453 fold_convert (long_integer_type_node, stride2));
5460 /* For assumed shape arrays move the upper bound by the same amount
5461 as the lower bound. */
5462 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5463 gfc_array_index_type, dubound, dlbound);
5464 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5465 gfc_array_index_type, tmp, lbound);
5466 gfc_add_modify (&init, ubound, tmp);
5468 /* The offset of this dimension. offset = offset - lbound * stride. */
5469 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5471 offset = fold_build2_loc (input_location, MINUS_EXPR,
5472 gfc_array_index_type, offset, tmp);
5474 /* The size of this dimension, and the stride of the next. */
5475 if (n + 1 < sym->as->rank)
5477 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5479 if (no_repack || partial != NULL_TREE)
5481 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5483 /* Figure out the stride if not a known constant. */
5484 if (!INTEGER_CST_P (stride))
5487 stmt_packed = NULL_TREE;
5490 /* Calculate stride = size * (ubound + 1 - lbound). */
5491 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5492 gfc_array_index_type,
5493 gfc_index_one_node, lbound);
5494 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5495 gfc_array_index_type, ubound, tmp);
5496 size = fold_build2_loc (input_location, MULT_EXPR,
5497 gfc_array_index_type, size, tmp);
5501 /* Assign the stride. */
5502 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5503 tmp = fold_build3_loc (input_location, COND_EXPR,
5504 gfc_array_index_type, partial,
5505 stmt_unpacked, stmt_packed);
5507 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5508 gfc_add_modify (&init, stride, tmp);
5513 stride = GFC_TYPE_ARRAY_SIZE (type);
5515 if (stride && !INTEGER_CST_P (stride))
5517 /* Calculate size = stride * (ubound + 1 - lbound). */
5518 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5519 gfc_array_index_type,
5520 gfc_index_one_node, lbound);
5521 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5522 gfc_array_index_type,
5524 tmp = fold_build2_loc (input_location, MULT_EXPR,
5525 gfc_array_index_type,
5526 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5527 gfc_add_modify (&init, stride, tmp);
5532 gfc_trans_array_cobounds (type, &init, sym);
5534 /* Set the offset. */
5535 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5536 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5538 gfc_trans_vla_type_sizes (sym, &init);
5540 stmtInit = gfc_finish_block (&init);
5542 /* Only do the entry/initialization code if the arg is present. */
5543 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5544 optional_arg = (sym->attr.optional
5545 || (sym->ns->proc_name->attr.entry_master
5546 && sym->attr.dummy));
5549 tmp = gfc_conv_expr_present (sym);
5550 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5551 build_empty_stmt (input_location));
5556 stmtCleanup = NULL_TREE;
5559 stmtblock_t cleanup;
5560 gfc_start_block (&cleanup);
5562 if (sym->attr.intent != INTENT_IN)
5564 /* Copy the data back. */
5565 tmp = build_call_expr_loc (input_location,
5566 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5567 gfc_add_expr_to_block (&cleanup, tmp);
5570 /* Free the temporary. */
5571 tmp = gfc_call_free (tmpdesc);
5572 gfc_add_expr_to_block (&cleanup, tmp);
5574 stmtCleanup = gfc_finish_block (&cleanup);
5576 /* Only do the cleanup if the array was repacked. */
5577 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5578 tmp = gfc_conv_descriptor_data_get (tmp);
5579 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5581 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5582 build_empty_stmt (input_location));
5586 tmp = gfc_conv_expr_present (sym);
5587 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5588 build_empty_stmt (input_location));
5592 /* We don't need to free any memory allocated by internal_pack as it will
5593 be freed at the end of the function by pop_context. */
5594 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5596 gfc_restore_backend_locus (&loc);
5600 /* Calculate the overall offset, including subreferences. */
5602 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5603 bool subref, gfc_expr *expr)
5613 /* If offset is NULL and this is not a subreferenced array, there is
5615 if (offset == NULL_TREE)
5618 offset = gfc_index_zero_node;
5623 tmp = gfc_conv_array_data (desc);
5624 tmp = build_fold_indirect_ref_loc (input_location,
5626 tmp = gfc_build_array_ref (tmp, offset, NULL);
5628 /* Offset the data pointer for pointer assignments from arrays with
5629 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5632 /* Go past the array reference. */
5633 for (ref = expr->ref; ref; ref = ref->next)
5634 if (ref->type == REF_ARRAY &&
5635 ref->u.ar.type != AR_ELEMENT)
5641 /* Calculate the offset for each subsequent subreference. */
5642 for (; ref; ref = ref->next)
5647 field = ref->u.c.component->backend_decl;
5648 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5649 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5651 tmp, field, NULL_TREE);
5655 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5656 gfc_init_se (&start, NULL);
5657 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5658 gfc_add_block_to_block (block, &start.pre);
5659 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5663 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5664 && ref->u.ar.type == AR_ELEMENT);
5666 /* TODO - Add bounds checking. */
5667 stride = gfc_index_one_node;
5668 index = gfc_index_zero_node;
5669 for (n = 0; n < ref->u.ar.dimen; n++)
5674 /* Update the index. */
5675 gfc_init_se (&start, NULL);
5676 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5677 itmp = gfc_evaluate_now (start.expr, block);
5678 gfc_init_se (&start, NULL);
5679 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5680 jtmp = gfc_evaluate_now (start.expr, block);
5681 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5682 gfc_array_index_type, itmp, jtmp);
5683 itmp = fold_build2_loc (input_location, MULT_EXPR,
5684 gfc_array_index_type, itmp, stride);
5685 index = fold_build2_loc (input_location, PLUS_EXPR,
5686 gfc_array_index_type, itmp, index);
5687 index = gfc_evaluate_now (index, block);
5689 /* Update the stride. */
5690 gfc_init_se (&start, NULL);
5691 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5692 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5693 gfc_array_index_type, start.expr,
5695 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5696 gfc_array_index_type,
5697 gfc_index_one_node, itmp);
5698 stride = fold_build2_loc (input_location, MULT_EXPR,
5699 gfc_array_index_type, stride, itmp);
5700 stride = gfc_evaluate_now (stride, block);
5703 /* Apply the index to obtain the array element. */
5704 tmp = gfc_build_array_ref (tmp, index, NULL);
5714 /* Set the target data pointer. */
5715 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5716 gfc_conv_descriptor_data_set (block, parm, offset);
5720 /* gfc_conv_expr_descriptor needs the string length an expression
5721 so that the size of the temporary can be obtained. This is done
5722 by adding up the string lengths of all the elements in the
5723 expression. Function with non-constant expressions have their
5724 string lengths mapped onto the actual arguments using the
5725 interface mapping machinery in trans-expr.c. */
5727 get_array_charlen (gfc_expr *expr, gfc_se *se)
5729 gfc_interface_mapping mapping;
5730 gfc_formal_arglist *formal;
5731 gfc_actual_arglist *arg;
5734 if (expr->ts.u.cl->length
5735 && gfc_is_constant_expr (expr->ts.u.cl->length))
5737 if (!expr->ts.u.cl->backend_decl)
5738 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5742 switch (expr->expr_type)
5745 get_array_charlen (expr->value.op.op1, se);
5747 /* For parentheses the expression ts.u.cl is identical. */
5748 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5751 expr->ts.u.cl->backend_decl =
5752 gfc_create_var (gfc_charlen_type_node, "sln");
5754 if (expr->value.op.op2)
5756 get_array_charlen (expr->value.op.op2, se);
5758 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5760 /* Add the string lengths and assign them to the expression
5761 string length backend declaration. */
5762 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5763 fold_build2_loc (input_location, PLUS_EXPR,
5764 gfc_charlen_type_node,
5765 expr->value.op.op1->ts.u.cl->backend_decl,
5766 expr->value.op.op2->ts.u.cl->backend_decl));
5769 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5770 expr->value.op.op1->ts.u.cl->backend_decl);
5774 if (expr->value.function.esym == NULL
5775 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5777 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5781 /* Map expressions involving the dummy arguments onto the actual
5782 argument expressions. */
5783 gfc_init_interface_mapping (&mapping);
5784 formal = expr->symtree->n.sym->formal;
5785 arg = expr->value.function.actual;
5787 /* Set se = NULL in the calls to the interface mapping, to suppress any
5789 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5794 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5797 gfc_init_se (&tse, NULL);
5799 /* Build the expression for the character length and convert it. */
5800 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5802 gfc_add_block_to_block (&se->pre, &tse.pre);
5803 gfc_add_block_to_block (&se->post, &tse.post);
5804 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5805 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5806 gfc_charlen_type_node, tse.expr,
5807 build_int_cst (gfc_charlen_type_node, 0));
5808 expr->ts.u.cl->backend_decl = tse.expr;
5809 gfc_free_interface_mapping (&mapping);
5813 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5819 /* Helper function to check dimensions. */
5821 transposed_dims (gfc_ss *ss)
5825 for (n = 0; n < ss->dimen; n++)
5826 if (ss->dim[n] != n)
5831 /* Convert an array for passing as an actual argument. Expressions and
5832 vector subscripts are evaluated and stored in a temporary, which is then
5833 passed. For whole arrays the descriptor is passed. For array sections
5834 a modified copy of the descriptor is passed, but using the original data.
5836 This function is also used for array pointer assignments, and there
5839 - se->want_pointer && !se->direct_byref
5840 EXPR is an actual argument. On exit, se->expr contains a
5841 pointer to the array descriptor.
5843 - !se->want_pointer && !se->direct_byref
5844 EXPR is an actual argument to an intrinsic function or the
5845 left-hand side of a pointer assignment. On exit, se->expr
5846 contains the descriptor for EXPR.
5848 - !se->want_pointer && se->direct_byref
5849 EXPR is the right-hand side of a pointer assignment and
5850 se->expr is the descriptor for the previously-evaluated
5851 left-hand side. The function creates an assignment from
5855 The se->force_tmp flag disables the non-copying descriptor optimization
5856 that is used for transpose. It may be used in cases where there is an
5857 alias between the transpose argument and another argument in the same
5861 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5863 gfc_ss_type ss_type;
5864 gfc_ss_info *ss_info;
5866 gfc_array_info *info;
5875 bool subref_array_target = false;
5876 gfc_expr *arg, *ss_expr;
5878 gcc_assert (ss != NULL);
5879 gcc_assert (ss != gfc_ss_terminator);
5882 ss_type = ss_info->type;
5883 ss_expr = ss_info->expr;
5885 /* Special case things we know we can pass easily. */
5886 switch (expr->expr_type)
5889 /* If we have a linear array section, we can pass it directly.
5890 Otherwise we need to copy it into a temporary. */
5892 gcc_assert (ss_type == GFC_SS_SECTION);
5893 gcc_assert (ss_expr == expr);
5894 info = &ss_info->data.array;
5896 /* Get the descriptor for the array. */
5897 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5898 desc = info->descriptor;
5900 subref_array_target = se->direct_byref && is_subref_array (expr);
5901 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5902 && !subref_array_target;
5909 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5911 /* Create a new descriptor if the array doesn't have one. */
5914 else if (info->ref->u.ar.type == AR_FULL)
5916 else if (se->direct_byref)
5919 full = gfc_full_array_ref_p (info->ref, NULL);
5921 if (full && !transposed_dims (ss))
5923 if (se->direct_byref && !se->byref_noassign)
5925 /* Copy the descriptor for pointer assignments. */
5926 gfc_add_modify (&se->pre, se->expr, desc);
5928 /* Add any offsets from subreferences. */
5929 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5930 subref_array_target, expr);
5932 else if (se->want_pointer)
5934 /* We pass full arrays directly. This means that pointers and
5935 allocatable arrays should also work. */
5936 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5943 if (expr->ts.type == BT_CHARACTER)
5944 se->string_length = gfc_get_expr_charlen (expr);
5952 /* We don't need to copy data in some cases. */
5953 arg = gfc_get_noncopying_intrinsic_argument (expr);
5956 /* This is a call to transpose... */
5957 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5958 /* ... which has already been handled by the scalarizer, so
5959 that we just need to get its argument's descriptor. */
5960 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5964 /* A transformational function return value will be a temporary
5965 array descriptor. We still need to go through the scalarizer
5966 to create the descriptor. Elemental functions ar handled as
5967 arbitrary expressions, i.e. copy to a temporary. */
5969 if (se->direct_byref)
5971 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
5973 /* For pointer assignments pass the descriptor directly. */
5977 gcc_assert (se->ss == ss);
5978 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5979 gfc_conv_expr (se, expr);
5983 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
5985 if (ss_expr != expr)
5986 /* Elemental function. */
5987 gcc_assert ((expr->value.function.esym != NULL
5988 && expr->value.function.esym->attr.elemental)
5989 || (expr->value.function.isym != NULL
5990 && expr->value.function.isym->elemental));
5992 gcc_assert (ss_type == GFC_SS_INTRINSIC);
5995 if (expr->ts.type == BT_CHARACTER
5996 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5997 get_array_charlen (expr, se);
6003 /* Transformational function. */
6004 info = &ss_info->data.array;
6010 /* Constant array constructors don't need a temporary. */
6011 if (ss_type == GFC_SS_CONSTRUCTOR
6012 && expr->ts.type != BT_CHARACTER
6013 && gfc_constant_array_constructor_p (expr->value.constructor))
6016 info = &ss_info->data.array;
6026 /* Something complicated. Copy it into a temporary. */
6032 /* If we are creating a temporary, we don't need to bother about aliases
6037 gfc_init_loopinfo (&loop);
6039 /* Associate the SS with the loop. */
6040 gfc_add_ss_to_loop (&loop, ss);
6042 /* Tell the scalarizer not to bother creating loop variables, etc. */
6044 loop.array_parameter = 1;
6046 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6047 gcc_assert (!se->direct_byref);
6049 /* Setup the scalarizing loops and bounds. */
6050 gfc_conv_ss_startstride (&loop);
6054 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6055 get_array_charlen (expr, se);
6057 /* Tell the scalarizer to make a temporary. */
6058 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6059 ((expr->ts.type == BT_CHARACTER)
6060 ? expr->ts.u.cl->backend_decl
6064 se->string_length = loop.temp_ss->info->string_length;
6065 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6066 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6069 gfc_conv_loop_setup (&loop, & expr->where);
6073 /* Copy into a temporary and pass that. We don't need to copy the data
6074 back because expressions and vector subscripts must be INTENT_IN. */
6075 /* TODO: Optimize passing function return values. */
6079 /* Start the copying loops. */
6080 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6081 gfc_mark_ss_chain_used (ss, 1);
6082 gfc_start_scalarized_body (&loop, &block);
6084 /* Copy each data element. */
6085 gfc_init_se (&lse, NULL);
6086 gfc_copy_loopinfo_to_se (&lse, &loop);
6087 gfc_init_se (&rse, NULL);
6088 gfc_copy_loopinfo_to_se (&rse, &loop);
6090 lse.ss = loop.temp_ss;
6093 gfc_conv_scalarized_array_ref (&lse, NULL);
6094 if (expr->ts.type == BT_CHARACTER)
6096 gfc_conv_expr (&rse, expr);
6097 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6098 rse.expr = build_fold_indirect_ref_loc (input_location,
6102 gfc_conv_expr_val (&rse, expr);
6104 gfc_add_block_to_block (&block, &rse.pre);
6105 gfc_add_block_to_block (&block, &lse.pre);
6107 lse.string_length = rse.string_length;
6108 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6109 expr->expr_type == EXPR_VARIABLE
6110 || expr->expr_type == EXPR_ARRAY, true);
6111 gfc_add_expr_to_block (&block, tmp);
6113 /* Finish the copying loops. */
6114 gfc_trans_scalarizing_loops (&loop, &block);
6116 desc = loop.temp_ss->info->data.array.descriptor;
6118 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6120 desc = info->descriptor;
6121 se->string_length = ss_info->string_length;
6125 /* We pass sections without copying to a temporary. Make a new
6126 descriptor and point it at the section we want. The loop variable
6127 limits will be the limits of the section.
6128 A function may decide to repack the array to speed up access, but
6129 we're not bothered about that here. */
6130 int dim, ndim, codim;
6138 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6140 if (se->want_coarray)
6142 gfc_array_ref *ar = &info->ref->u.ar;
6144 codim = gfc_get_corank (expr);
6145 for (n = 0; n < codim - 1; n++)
6147 /* Make sure we are not lost somehow. */
6148 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6150 /* Make sure the call to gfc_conv_section_startstride won't
6151 generate unnecessary code to calculate stride. */
6152 gcc_assert (ar->stride[n + ndim] == NULL);
6154 gfc_conv_section_startstride (&loop, ss, n + ndim);
6155 loop.from[n + loop.dimen] = info->start[n + ndim];
6156 loop.to[n + loop.dimen] = info->end[n + ndim];
6159 gcc_assert (n == codim - 1);
6160 evaluate_bound (&loop.pre, info->start, ar->start,
6161 info->descriptor, n + ndim, true);
6162 loop.from[n + loop.dimen] = info->start[n + ndim];
6167 /* Set the string_length for a character array. */
6168 if (expr->ts.type == BT_CHARACTER)
6169 se->string_length = gfc_get_expr_charlen (expr);
6171 desc = info->descriptor;
6172 if (se->direct_byref && !se->byref_noassign)
6174 /* For pointer assignments we fill in the destination. */
6176 parmtype = TREE_TYPE (parm);
6180 /* Otherwise make a new one. */
6181 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6182 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6183 loop.from, loop.to, 0,
6184 GFC_ARRAY_UNKNOWN, false);
6185 parm = gfc_create_var (parmtype, "parm");
6188 offset = gfc_index_zero_node;
6190 /* The following can be somewhat confusing. We have two
6191 descriptors, a new one and the original array.
6192 {parm, parmtype, dim} refer to the new one.
6193 {desc, type, n, loop} refer to the original, which maybe
6194 a descriptorless array.
6195 The bounds of the scalarization are the bounds of the section.
6196 We don't have to worry about numeric overflows when calculating
6197 the offsets because all elements are within the array data. */
6199 /* Set the dtype. */
6200 tmp = gfc_conv_descriptor_dtype (parm);
6201 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6203 /* Set offset for assignments to pointer only to zero if it is not
6205 if (se->direct_byref
6206 && info->ref && info->ref->u.ar.type != AR_FULL)
6207 base = gfc_index_zero_node;
6208 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6209 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6213 for (n = 0; n < ndim; n++)
6215 stride = gfc_conv_array_stride (desc, n);
6217 /* Work out the offset. */
6219 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6221 gcc_assert (info->subscript[n]
6222 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6223 start = info->subscript[n]->info->data.scalar.value;
6227 /* Evaluate and remember the start of the section. */
6228 start = info->start[n];
6229 stride = gfc_evaluate_now (stride, &loop.pre);
6232 tmp = gfc_conv_array_lbound (desc, n);
6233 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6235 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6237 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6241 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6243 /* For elemental dimensions, we only need the offset. */
6247 /* Vector subscripts need copying and are handled elsewhere. */
6249 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6251 /* look for the corresponding scalarizer dimension: dim. */
6252 for (dim = 0; dim < ndim; dim++)
6253 if (ss->dim[dim] == n)
6256 /* loop exited early: the DIM being looked for has been found. */
6257 gcc_assert (dim < ndim);
6259 /* Set the new lower bound. */
6260 from = loop.from[dim];
6263 /* If we have an array section or are assigning make sure that
6264 the lower bound is 1. References to the full
6265 array should otherwise keep the original bounds. */
6267 || info->ref->u.ar.type != AR_FULL)
6268 && !integer_onep (from))
6270 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6271 gfc_array_index_type, gfc_index_one_node,
6273 to = fold_build2_loc (input_location, PLUS_EXPR,
6274 gfc_array_index_type, to, tmp);
6275 from = gfc_index_one_node;
6277 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6278 gfc_rank_cst[dim], from);
6280 /* Set the new upper bound. */
6281 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6282 gfc_rank_cst[dim], to);
6284 /* Multiply the stride by the section stride to get the
6286 stride = fold_build2_loc (input_location, MULT_EXPR,
6287 gfc_array_index_type,
6288 stride, info->stride[n]);
6290 if (se->direct_byref
6292 && info->ref->u.ar.type != AR_FULL)
6294 base = fold_build2_loc (input_location, MINUS_EXPR,
6295 TREE_TYPE (base), base, stride);
6297 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6299 tmp = gfc_conv_array_lbound (desc, n);
6300 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6301 TREE_TYPE (base), tmp, loop.from[dim]);
6302 tmp = fold_build2_loc (input_location, MULT_EXPR,
6303 TREE_TYPE (base), tmp,
6304 gfc_conv_array_stride (desc, n));
6305 base = fold_build2_loc (input_location, PLUS_EXPR,
6306 TREE_TYPE (base), tmp, base);
6309 /* Store the new stride. */
6310 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6311 gfc_rank_cst[dim], stride);
6314 for (n = loop.dimen; n < loop.dimen + codim; n++)
6316 from = loop.from[n];
6318 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6319 gfc_rank_cst[n], from);
6320 if (n < loop.dimen + codim - 1)
6321 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6322 gfc_rank_cst[n], to);
6325 if (se->data_not_needed)
6326 gfc_conv_descriptor_data_set (&loop.pre, parm,
6327 gfc_index_zero_node);
6329 /* Point the data pointer at the 1st element in the section. */
6330 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6331 subref_array_target, expr);
6333 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6334 && !se->data_not_needed)
6336 /* Set the offset. */
6337 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6341 /* Only the callee knows what the correct offset it, so just set
6343 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6348 if (!se->direct_byref || se->byref_noassign)
6350 /* Get a pointer to the new descriptor. */
6351 if (se->want_pointer)
6352 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6357 gfc_add_block_to_block (&se->pre, &loop.pre);
6358 gfc_add_block_to_block (&se->post, &loop.post);
6360 /* Cleanup the scalarizer. */
6361 gfc_cleanup_loop (&loop);
6364 /* Helper function for gfc_conv_array_parameter if array size needs to be
6368 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6371 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6372 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6373 else if (expr->rank > 1)
6374 *size = build_call_expr_loc (input_location,
6375 gfor_fndecl_size0, 1,
6376 gfc_build_addr_expr (NULL, desc));
6379 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6380 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6382 *size = fold_build2_loc (input_location, MINUS_EXPR,
6383 gfc_array_index_type, ubound, lbound);
6384 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6385 *size, gfc_index_one_node);
6386 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6387 *size, gfc_index_zero_node);
6389 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6390 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6391 *size, fold_convert (gfc_array_index_type, elem));
6394 /* Convert an array for passing as an actual parameter. */
6395 /* TODO: Optimize passing g77 arrays. */
6398 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6399 const gfc_symbol *fsym, const char *proc_name,
6404 tree tmp = NULL_TREE;
6406 tree parent = DECL_CONTEXT (current_function_decl);
6407 bool full_array_var;
6408 bool this_array_result;
6411 bool array_constructor;
6412 bool good_allocatable;
6413 bool ultimate_ptr_comp;
6414 bool ultimate_alloc_comp;
6419 ultimate_ptr_comp = false;
6420 ultimate_alloc_comp = false;
6422 for (ref = expr->ref; ref; ref = ref->next)
6424 if (ref->next == NULL)
6427 if (ref->type == REF_COMPONENT)
6429 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6430 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6434 full_array_var = false;
6437 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6438 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6440 sym = full_array_var ? expr->symtree->n.sym : NULL;
6442 /* The symbol should have an array specification. */
6443 gcc_assert (!sym || sym->as || ref->u.ar.as);
6445 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6447 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6448 expr->ts.u.cl->backend_decl = tmp;
6449 se->string_length = tmp;
6452 /* Is this the result of the enclosing procedure? */
6453 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6454 if (this_array_result
6455 && (sym->backend_decl != current_function_decl)
6456 && (sym->backend_decl != parent))
6457 this_array_result = false;
6459 /* Passing address of the array if it is not pointer or assumed-shape. */
6460 if (full_array_var && g77 && !this_array_result)
6462 tmp = gfc_get_symbol_decl (sym);
6464 if (sym->ts.type == BT_CHARACTER)
6465 se->string_length = sym->ts.u.cl->backend_decl;
6467 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6469 gfc_conv_expr_descriptor (se, expr, ss);
6470 se->expr = gfc_conv_array_data (se->expr);
6474 if (!sym->attr.pointer
6476 && sym->as->type != AS_ASSUMED_SHAPE
6477 && !sym->attr.allocatable)
6479 /* Some variables are declared directly, others are declared as
6480 pointers and allocated on the heap. */
6481 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6484 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6486 array_parameter_size (tmp, expr, size);
6490 if (sym->attr.allocatable)
6492 if (sym->attr.dummy || sym->attr.result)
6494 gfc_conv_expr_descriptor (se, expr, ss);
6498 array_parameter_size (tmp, expr, size);
6499 se->expr = gfc_conv_array_data (tmp);
6504 /* A convenient reduction in scope. */
6505 contiguous = g77 && !this_array_result && contiguous;
6507 /* There is no need to pack and unpack the array, if it is contiguous
6508 and not a deferred- or assumed-shape array, or if it is simply
6510 no_pack = ((sym && sym->as
6511 && !sym->attr.pointer
6512 && sym->as->type != AS_DEFERRED
6513 && sym->as->type != AS_ASSUMED_SHAPE)
6515 (ref && ref->u.ar.as
6516 && ref->u.ar.as->type != AS_DEFERRED
6517 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6519 gfc_is_simply_contiguous (expr, false));
6521 no_pack = contiguous && no_pack;
6523 /* Array constructors are always contiguous and do not need packing. */
6524 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6526 /* Same is true of contiguous sections from allocatable variables. */
6527 good_allocatable = contiguous
6529 && expr->symtree->n.sym->attr.allocatable;
6531 /* Or ultimate allocatable components. */
6532 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6534 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6536 gfc_conv_expr_descriptor (se, expr, ss);
6537 if (expr->ts.type == BT_CHARACTER)
6538 se->string_length = expr->ts.u.cl->backend_decl;
6540 array_parameter_size (se->expr, expr, size);
6541 se->expr = gfc_conv_array_data (se->expr);
6545 if (this_array_result)
6547 /* Result of the enclosing function. */
6548 gfc_conv_expr_descriptor (se, expr, ss);
6550 array_parameter_size (se->expr, expr, size);
6551 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6553 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6554 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6555 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6562 /* Every other type of array. */
6563 se->want_pointer = 1;
6564 gfc_conv_expr_descriptor (se, expr, ss);
6566 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6571 /* Deallocate the allocatable components of structures that are
6573 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6574 && expr->ts.u.derived->attr.alloc_comp
6575 && expr->expr_type != EXPR_VARIABLE)
6577 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6578 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6580 /* The components shall be deallocated before their containing entity. */
6581 gfc_prepend_expr_to_block (&se->post, tmp);
6584 if (g77 || (fsym && fsym->attr.contiguous
6585 && !gfc_is_simply_contiguous (expr, false)))
6587 tree origptr = NULL_TREE;
6591 /* For contiguous arrays, save the original value of the descriptor. */
6594 origptr = gfc_create_var (pvoid_type_node, "origptr");
6595 tmp = build_fold_indirect_ref_loc (input_location, desc);
6596 tmp = gfc_conv_array_data (tmp);
6597 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6598 TREE_TYPE (origptr), origptr,
6599 fold_convert (TREE_TYPE (origptr), tmp));
6600 gfc_add_expr_to_block (&se->pre, tmp);
6603 /* Repack the array. */
6604 if (gfc_option.warn_array_temp)
6607 gfc_warning ("Creating array temporary at %L for argument '%s'",
6608 &expr->where, fsym->name);
6610 gfc_warning ("Creating array temporary at %L", &expr->where);
6613 ptr = build_call_expr_loc (input_location,
6614 gfor_fndecl_in_pack, 1, desc);
6616 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6618 tmp = gfc_conv_expr_present (sym);
6619 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6620 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6621 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6624 ptr = gfc_evaluate_now (ptr, &se->pre);
6626 /* Use the packed data for the actual argument, except for contiguous arrays,
6627 where the descriptor's data component is set. */
6632 tmp = build_fold_indirect_ref_loc (input_location, desc);
6633 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6636 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6640 if (fsym && proc_name)
6641 asprintf (&msg, "An array temporary was created for argument "
6642 "'%s' of procedure '%s'", fsym->name, proc_name);
6644 asprintf (&msg, "An array temporary was created");
6646 tmp = build_fold_indirect_ref_loc (input_location,
6648 tmp = gfc_conv_array_data (tmp);
6649 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6650 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6652 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6653 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6655 gfc_conv_expr_present (sym), tmp);
6657 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6662 gfc_start_block (&block);
6664 /* Copy the data back. */
6665 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6667 tmp = build_call_expr_loc (input_location,
6668 gfor_fndecl_in_unpack, 2, desc, ptr);
6669 gfc_add_expr_to_block (&block, tmp);
6672 /* Free the temporary. */
6673 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6674 gfc_add_expr_to_block (&block, tmp);
6676 stmt = gfc_finish_block (&block);
6678 gfc_init_block (&block);
6679 /* Only if it was repacked. This code needs to be executed before the
6680 loop cleanup code. */
6681 tmp = build_fold_indirect_ref_loc (input_location,
6683 tmp = gfc_conv_array_data (tmp);
6684 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6685 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6687 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6688 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6690 gfc_conv_expr_present (sym), tmp);
6692 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6694 gfc_add_expr_to_block (&block, tmp);
6695 gfc_add_block_to_block (&block, &se->post);
6697 gfc_init_block (&se->post);
6699 /* Reset the descriptor pointer. */
6702 tmp = build_fold_indirect_ref_loc (input_location, desc);
6703 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6706 gfc_add_block_to_block (&se->post, &block);
6711 /* Generate code to deallocate an array, if it is allocated. */
6714 gfc_trans_dealloc_allocated (tree descriptor)
6720 gfc_start_block (&block);
6722 var = gfc_conv_descriptor_data_get (descriptor);
6725 /* Call array_deallocate with an int * present in the second argument.
6726 Although it is ignored here, it's presence ensures that arrays that
6727 are already deallocated are ignored. */
6728 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6729 gfc_add_expr_to_block (&block, tmp);
6731 /* Zero the data pointer. */
6732 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6733 var, build_int_cst (TREE_TYPE (var), 0));
6734 gfc_add_expr_to_block (&block, tmp);
6736 return gfc_finish_block (&block);
6740 /* This helper function calculates the size in words of a full array. */
6743 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6748 idx = gfc_rank_cst[rank - 1];
6749 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6750 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6751 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6753 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6754 tmp, gfc_index_one_node);
6755 tmp = gfc_evaluate_now (tmp, block);
6757 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6758 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6760 return gfc_evaluate_now (tmp, block);
6764 /* Allocate dest to the same size as src, and copy src -> dest.
6765 If no_malloc is set, only the copy is done. */
6768 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6778 /* If the source is null, set the destination to null. Then,
6779 allocate memory to the destination. */
6780 gfc_init_block (&block);
6784 tmp = null_pointer_node;
6785 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6786 gfc_add_expr_to_block (&block, tmp);
6787 null_data = gfc_finish_block (&block);
6789 gfc_init_block (&block);
6790 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6793 tmp = gfc_call_malloc (&block, type, size);
6794 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6795 dest, fold_convert (type, tmp));
6796 gfc_add_expr_to_block (&block, tmp);
6799 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6800 tmp = build_call_expr_loc (input_location, tmp, 3,
6805 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6806 null_data = gfc_finish_block (&block);
6808 gfc_init_block (&block);
6809 nelems = get_full_array_size (&block, src, rank);
6810 tmp = fold_convert (gfc_array_index_type,
6811 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6812 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6816 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6817 tmp = gfc_call_malloc (&block, tmp, size);
6818 gfc_conv_descriptor_data_set (&block, dest, tmp);
6821 /* We know the temporary and the value will be the same length,
6822 so can use memcpy. */
6823 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6824 tmp = build_call_expr_loc (input_location,
6825 tmp, 3, gfc_conv_descriptor_data_get (dest),
6826 gfc_conv_descriptor_data_get (src), size);
6829 gfc_add_expr_to_block (&block, tmp);
6830 tmp = gfc_finish_block (&block);
6832 /* Null the destination if the source is null; otherwise do
6833 the allocate and copy. */
6837 null_cond = gfc_conv_descriptor_data_get (src);
6839 null_cond = convert (pvoid_type_node, null_cond);
6840 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6841 null_cond, null_pointer_node);
6842 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6846 /* Allocate dest to the same size as src, and copy data src -> dest. */
6849 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6851 return duplicate_allocatable (dest, src, type, rank, false);
6855 /* Copy data src -> dest. */
6858 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6860 return duplicate_allocatable (dest, src, type, rank, true);
6864 /* Recursively traverse an object of derived type, generating code to
6865 deallocate, nullify or copy allocatable components. This is the work horse
6866 function for the functions named in this enum. */
6868 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6869 COPY_ONLY_ALLOC_COMP};
6872 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6873 tree dest, int rank, int purpose)
6877 stmtblock_t fnblock;
6878 stmtblock_t loopbody;
6889 tree null_cond = NULL_TREE;
6891 gfc_init_block (&fnblock);
6893 decl_type = TREE_TYPE (decl);
6895 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6896 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6898 decl = build_fold_indirect_ref_loc (input_location,
6901 /* Just in case in gets dereferenced. */
6902 decl_type = TREE_TYPE (decl);
6904 /* If this an array of derived types with allocatable components
6905 build a loop and recursively call this function. */
6906 if (TREE_CODE (decl_type) == ARRAY_TYPE
6907 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6909 tmp = gfc_conv_array_data (decl);
6910 var = build_fold_indirect_ref_loc (input_location,
6913 /* Get the number of elements - 1 and set the counter. */
6914 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6916 /* Use the descriptor for an allocatable array. Since this
6917 is a full array reference, we only need the descriptor
6918 information from dimension = rank. */
6919 tmp = get_full_array_size (&fnblock, decl, rank);
6920 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6921 gfc_array_index_type, tmp,
6922 gfc_index_one_node);
6924 null_cond = gfc_conv_descriptor_data_get (decl);
6925 null_cond = fold_build2_loc (input_location, NE_EXPR,
6926 boolean_type_node, null_cond,
6927 build_int_cst (TREE_TYPE (null_cond), 0));
6931 /* Otherwise use the TYPE_DOMAIN information. */
6932 tmp = array_type_nelts (decl_type);
6933 tmp = fold_convert (gfc_array_index_type, tmp);
6936 /* Remember that this is, in fact, the no. of elements - 1. */
6937 nelems = gfc_evaluate_now (tmp, &fnblock);
6938 index = gfc_create_var (gfc_array_index_type, "S");
6940 /* Build the body of the loop. */
6941 gfc_init_block (&loopbody);
6943 vref = gfc_build_array_ref (var, index, NULL);
6945 if (purpose == COPY_ALLOC_COMP)
6947 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6949 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6950 gfc_add_expr_to_block (&fnblock, tmp);
6952 tmp = build_fold_indirect_ref_loc (input_location,
6953 gfc_conv_array_data (dest));
6954 dref = gfc_build_array_ref (tmp, index, NULL);
6955 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6957 else if (purpose == COPY_ONLY_ALLOC_COMP)
6959 tmp = build_fold_indirect_ref_loc (input_location,
6960 gfc_conv_array_data (dest));
6961 dref = gfc_build_array_ref (tmp, index, NULL);
6962 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6966 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6968 gfc_add_expr_to_block (&loopbody, tmp);
6970 /* Build the loop and return. */
6971 gfc_init_loopinfo (&loop);
6973 loop.from[0] = gfc_index_zero_node;
6974 loop.loopvar[0] = index;
6975 loop.to[0] = nelems;
6976 gfc_trans_scalarizing_loops (&loop, &loopbody);
6977 gfc_add_block_to_block (&fnblock, &loop.pre);
6979 tmp = gfc_finish_block (&fnblock);
6980 if (null_cond != NULL_TREE)
6981 tmp = build3_v (COND_EXPR, null_cond, tmp,
6982 build_empty_stmt (input_location));
6987 /* Otherwise, act on the components or recursively call self to
6988 act on a chain of components. */
6989 for (c = der_type->components; c; c = c->next)
6991 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6992 || c->ts.type == BT_CLASS)
6993 && c->ts.u.derived->attr.alloc_comp;
6994 cdecl = c->backend_decl;
6995 ctype = TREE_TYPE (cdecl);
6999 case DEALLOCATE_ALLOC_COMP:
7000 if (cmp_has_alloc_comps && !c->attr.pointer)
7002 /* Do not deallocate the components of ultimate pointer
7004 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7005 decl, cdecl, NULL_TREE);
7006 rank = c->as ? c->as->rank : 0;
7007 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7009 gfc_add_expr_to_block (&fnblock, tmp);
7012 if (c->attr.allocatable
7013 && (c->attr.dimension || c->attr.codimension))
7015 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7016 decl, cdecl, NULL_TREE);
7017 tmp = gfc_trans_dealloc_allocated (comp);
7018 gfc_add_expr_to_block (&fnblock, tmp);
7020 else if (c->attr.allocatable)
7022 /* Allocatable scalar components. */
7023 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7024 decl, cdecl, NULL_TREE);
7026 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7028 gfc_add_expr_to_block (&fnblock, tmp);
7030 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7031 void_type_node, comp,
7032 build_int_cst (TREE_TYPE (comp), 0));
7033 gfc_add_expr_to_block (&fnblock, tmp);
7035 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7037 /* Allocatable scalar CLASS components. */
7038 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7039 decl, cdecl, NULL_TREE);
7041 /* Add reference to '_data' component. */
7042 tmp = CLASS_DATA (c)->backend_decl;
7043 comp = fold_build3_loc (input_location, COMPONENT_REF,
7044 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7046 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7047 CLASS_DATA (c)->ts);
7048 gfc_add_expr_to_block (&fnblock, tmp);
7050 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7051 void_type_node, comp,
7052 build_int_cst (TREE_TYPE (comp), 0));
7053 gfc_add_expr_to_block (&fnblock, tmp);
7057 case NULLIFY_ALLOC_COMP:
7058 if (c->attr.pointer)
7060 else if (c->attr.allocatable
7061 && (c->attr.dimension|| c->attr.codimension))
7063 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7064 decl, cdecl, NULL_TREE);
7065 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7067 else if (c->attr.allocatable)
7069 /* Allocatable scalar components. */
7070 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7071 decl, cdecl, NULL_TREE);
7072 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7073 void_type_node, comp,
7074 build_int_cst (TREE_TYPE (comp), 0));
7075 gfc_add_expr_to_block (&fnblock, tmp);
7077 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7079 /* Allocatable scalar CLASS components. */
7080 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7081 decl, cdecl, NULL_TREE);
7082 /* Add reference to '_data' component. */
7083 tmp = CLASS_DATA (c)->backend_decl;
7084 comp = fold_build3_loc (input_location, COMPONENT_REF,
7085 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7086 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7087 void_type_node, comp,
7088 build_int_cst (TREE_TYPE (comp), 0));
7089 gfc_add_expr_to_block (&fnblock, tmp);
7091 else if (cmp_has_alloc_comps)
7093 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7094 decl, cdecl, NULL_TREE);
7095 rank = c->as ? c->as->rank : 0;
7096 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7098 gfc_add_expr_to_block (&fnblock, tmp);
7102 case COPY_ALLOC_COMP:
7103 if (c->attr.pointer)
7106 /* We need source and destination components. */
7107 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7109 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7111 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7113 if (c->attr.allocatable && !cmp_has_alloc_comps)
7115 rank = c->as ? c->as->rank : 0;
7116 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7117 gfc_add_expr_to_block (&fnblock, tmp);
7120 if (cmp_has_alloc_comps)
7122 rank = c->as ? c->as->rank : 0;
7123 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7124 gfc_add_modify (&fnblock, dcmp, tmp);
7125 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7127 gfc_add_expr_to_block (&fnblock, tmp);
7137 return gfc_finish_block (&fnblock);
7140 /* Recursively traverse an object of derived type, generating code to
7141 nullify allocatable components. */
7144 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7146 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7147 NULLIFY_ALLOC_COMP);
7151 /* Recursively traverse an object of derived type, generating code to
7152 deallocate allocatable components. */
7155 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7157 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7158 DEALLOCATE_ALLOC_COMP);
7162 /* Recursively traverse an object of derived type, generating code to
7163 copy it and its allocatable components. */
7166 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7168 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7172 /* Recursively traverse an object of derived type, generating code to
7173 copy only its allocatable components. */
7176 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7178 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7182 /* Returns the value of LBOUND for an expression. This could be broken out
7183 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7184 called by gfc_alloc_allocatable_for_assignment. */
7186 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7191 tree cond, cond1, cond3, cond4;
7195 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7197 tmp = gfc_rank_cst[dim];
7198 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7199 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7200 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7201 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7203 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7204 stride, gfc_index_zero_node);
7205 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7206 boolean_type_node, cond3, cond1);
7207 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7208 stride, gfc_index_zero_node);
7210 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7211 tmp, build_int_cst (gfc_array_index_type,
7214 cond = boolean_false_node;
7216 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7217 boolean_type_node, cond3, cond4);
7218 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7219 boolean_type_node, cond, cond1);
7221 return fold_build3_loc (input_location, COND_EXPR,
7222 gfc_array_index_type, cond,
7223 lbound, gfc_index_one_node);
7225 else if (expr->expr_type == EXPR_VARIABLE)
7227 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7228 for (ref = expr->ref; ref; ref = ref->next)
7230 if (ref->type == REF_COMPONENT
7231 && ref->u.c.component->as
7233 && ref->next->u.ar.type == AR_FULL)
7234 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7236 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7238 else if (expr->expr_type == EXPR_FUNCTION)
7240 /* A conversion function, so use the argument. */
7241 expr = expr->value.function.actual->expr;
7242 if (expr->expr_type != EXPR_VARIABLE)
7243 return gfc_index_one_node;
7244 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7245 return get_std_lbound (expr, desc, dim, assumed_size);
7248 return gfc_index_one_node;
7252 /* Returns true if an expression represents an lhs that can be reallocated
7256 gfc_is_reallocatable_lhs (gfc_expr *expr)
7263 /* An allocatable variable. */
7264 if (expr->symtree->n.sym->attr.allocatable
7266 && expr->ref->type == REF_ARRAY
7267 && expr->ref->u.ar.type == AR_FULL)
7270 /* All that can be left are allocatable components. */
7271 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7272 && expr->symtree->n.sym->ts.type != BT_CLASS)
7273 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7276 /* Find a component ref followed by an array reference. */
7277 for (ref = expr->ref; ref; ref = ref->next)
7279 && ref->type == REF_COMPONENT
7280 && ref->next->type == REF_ARRAY
7281 && !ref->next->next)
7287 /* Return true if valid reallocatable lhs. */
7288 if (ref->u.c.component->attr.allocatable
7289 && ref->next->u.ar.type == AR_FULL)
7296 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7300 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7304 stmtblock_t realloc_block;
7305 stmtblock_t alloc_block;
7309 gfc_array_info *linfo;
7329 gfc_array_spec * as;
7331 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7332 Find the lhs expression in the loop chain and set expr1 and
7333 expr2 accordingly. */
7334 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7337 /* Find the ss for the lhs. */
7339 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7340 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
7342 if (lss == gfc_ss_terminator)
7344 expr1 = lss->info->expr;
7347 /* Bail out if this is not a valid allocate on assignment. */
7348 if (!gfc_is_reallocatable_lhs (expr1)
7349 || (expr2 && !expr2->rank))
7352 /* Find the ss for the lhs. */
7354 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7355 if (lss->info->expr == expr1)
7358 if (lss == gfc_ss_terminator)
7361 linfo = &lss->info->data.array;
7363 /* Find an ss for the rhs. For operator expressions, we see the
7364 ss's for the operands. Any one of these will do. */
7366 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7367 if (rss->info->expr != expr1 && rss != loop->temp_ss)
7370 if (expr2 && rss == gfc_ss_terminator)
7373 gfc_start_block (&fblock);
7375 /* Since the lhs is allocatable, this must be a descriptor type.
7376 Get the data and array size. */
7377 desc = linfo->descriptor;
7378 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7379 array1 = gfc_conv_descriptor_data_get (desc);
7381 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7382 deallocated if expr is an array of different shape or any of the
7383 corresponding length type parameter values of variable and expr
7384 differ." This assures F95 compatibility. */
7385 jump_label1 = gfc_build_label_decl (NULL_TREE);
7386 jump_label2 = gfc_build_label_decl (NULL_TREE);
7388 /* Allocate if data is NULL. */
7389 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7390 array1, build_int_cst (TREE_TYPE (array1), 0));
7391 tmp = build3_v (COND_EXPR, cond,
7392 build1_v (GOTO_EXPR, jump_label1),
7393 build_empty_stmt (input_location));
7394 gfc_add_expr_to_block (&fblock, tmp);
7396 /* Get arrayspec if expr is a full array. */
7397 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7398 && expr2->value.function.isym
7399 && expr2->value.function.isym->conversion)
7401 /* For conversion functions, take the arg. */
7402 gfc_expr *arg = expr2->value.function.actual->expr;
7403 as = gfc_get_full_arrayspec_from_expr (arg);
7406 as = gfc_get_full_arrayspec_from_expr (expr2);
7410 /* If the lhs shape is not the same as the rhs jump to setting the
7411 bounds and doing the reallocation....... */
7412 for (n = 0; n < expr1->rank; n++)
7414 /* Check the shape. */
7415 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7416 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7417 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7418 gfc_array_index_type,
7419 loop->to[n], loop->from[n]);
7420 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7421 gfc_array_index_type,
7423 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7424 gfc_array_index_type,
7426 cond = fold_build2_loc (input_location, NE_EXPR,
7428 tmp, gfc_index_zero_node);
7429 tmp = build3_v (COND_EXPR, cond,
7430 build1_v (GOTO_EXPR, jump_label1),
7431 build_empty_stmt (input_location));
7432 gfc_add_expr_to_block (&fblock, tmp);
7435 /* ....else jump past the (re)alloc code. */
7436 tmp = build1_v (GOTO_EXPR, jump_label2);
7437 gfc_add_expr_to_block (&fblock, tmp);
7439 /* Add the label to start automatic (re)allocation. */
7440 tmp = build1_v (LABEL_EXPR, jump_label1);
7441 gfc_add_expr_to_block (&fblock, tmp);
7443 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7445 /* Get the rhs size. Fix both sizes. */
7447 desc2 = rss->info->data.array.descriptor;
7450 size2 = gfc_index_one_node;
7451 for (n = 0; n < expr2->rank; n++)
7453 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7454 gfc_array_index_type,
7455 loop->to[n], loop->from[n]);
7456 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7457 gfc_array_index_type,
7458 tmp, gfc_index_one_node);
7459 size2 = fold_build2_loc (input_location, MULT_EXPR,
7460 gfc_array_index_type,
7464 size1 = gfc_evaluate_now (size1, &fblock);
7465 size2 = gfc_evaluate_now (size2, &fblock);
7467 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7469 neq_size = gfc_evaluate_now (cond, &fblock);
7472 /* Now modify the lhs descriptor and the associated scalarizer
7473 variables. F2003 7.4.1.3: "If variable is or becomes an
7474 unallocated allocatable variable, then it is allocated with each
7475 deferred type parameter equal to the corresponding type parameters
7476 of expr , with the shape of expr , and with each lower bound equal
7477 to the corresponding element of LBOUND(expr)."
7478 Reuse size1 to keep a dimension-by-dimension track of the
7479 stride of the new array. */
7480 size1 = gfc_index_one_node;
7481 offset = gfc_index_zero_node;
7483 for (n = 0; n < expr2->rank; n++)
7485 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7486 gfc_array_index_type,
7487 loop->to[n], loop->from[n]);
7488 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7489 gfc_array_index_type,
7490 tmp, gfc_index_one_node);
7492 lbound = gfc_index_one_node;
7497 lbd = get_std_lbound (expr2, desc2, n,
7498 as->type == AS_ASSUMED_SIZE);
7499 ubound = fold_build2_loc (input_location,
7501 gfc_array_index_type,
7503 ubound = fold_build2_loc (input_location,
7505 gfc_array_index_type,
7510 gfc_conv_descriptor_lbound_set (&fblock, desc,
7513 gfc_conv_descriptor_ubound_set (&fblock, desc,
7516 gfc_conv_descriptor_stride_set (&fblock, desc,
7519 lbound = gfc_conv_descriptor_lbound_get (desc,
7521 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7522 gfc_array_index_type,
7524 offset = fold_build2_loc (input_location, MINUS_EXPR,
7525 gfc_array_index_type,
7527 size1 = fold_build2_loc (input_location, MULT_EXPR,
7528 gfc_array_index_type,
7532 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7533 the array offset is saved and the info.offset is used for a
7534 running offset. Use the saved_offset instead. */
7535 tmp = gfc_conv_descriptor_offset (desc);
7536 gfc_add_modify (&fblock, tmp, offset);
7537 if (linfo->saved_offset
7538 && TREE_CODE (linfo->saved_offset) == VAR_DECL)
7539 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
7541 /* Now set the deltas for the lhs. */
7542 for (n = 0; n < expr1->rank; n++)
7544 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7546 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7547 gfc_array_index_type, tmp,
7549 if (linfo->delta[dim]
7550 && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
7551 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
7554 /* Get the new lhs size in bytes. */
7555 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7557 tmp = expr2->ts.u.cl->backend_decl;
7558 gcc_assert (expr1->ts.u.cl->backend_decl);
7559 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7560 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7562 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7564 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7565 tmp = fold_build2_loc (input_location, MULT_EXPR,
7566 gfc_array_index_type, tmp,
7567 expr1->ts.u.cl->backend_decl);
7570 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7571 tmp = fold_convert (gfc_array_index_type, tmp);
7572 size2 = fold_build2_loc (input_location, MULT_EXPR,
7573 gfc_array_index_type,
7575 size2 = fold_convert (size_type_node, size2);
7576 size2 = gfc_evaluate_now (size2, &fblock);
7578 /* Realloc expression. Note that the scalarizer uses desc.data
7579 in the array reference - (*desc.data)[<element>]. */
7580 gfc_init_block (&realloc_block);
7581 tmp = build_call_expr_loc (input_location,
7582 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
7583 fold_convert (pvoid_type_node, array1),
7585 gfc_conv_descriptor_data_set (&realloc_block,
7587 realloc_expr = gfc_finish_block (&realloc_block);
7589 /* Only reallocate if sizes are different. */
7590 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7591 build_empty_stmt (input_location));
7595 /* Malloc expression. */
7596 gfc_init_block (&alloc_block);
7597 tmp = build_call_expr_loc (input_location,
7598 builtin_decl_explicit (BUILT_IN_MALLOC),
7600 gfc_conv_descriptor_data_set (&alloc_block,
7602 tmp = gfc_conv_descriptor_dtype (desc);
7603 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7604 alloc_expr = gfc_finish_block (&alloc_block);
7606 /* Malloc if not allocated; realloc otherwise. */
7607 tmp = build_int_cst (TREE_TYPE (array1), 0);
7608 cond = fold_build2_loc (input_location, EQ_EXPR,
7611 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7612 gfc_add_expr_to_block (&fblock, tmp);
7614 /* Make sure that the scalarizer data pointer is updated. */
7616 && TREE_CODE (linfo->data) == VAR_DECL)
7618 tmp = gfc_conv_descriptor_data_get (desc);
7619 gfc_add_modify (&fblock, linfo->data, tmp);
7622 /* Add the exit label. */
7623 tmp = build1_v (LABEL_EXPR, jump_label2);
7624 gfc_add_expr_to_block (&fblock, tmp);
7626 return gfc_finish_block (&fblock);
7630 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7631 Do likewise, recursively if necessary, with the allocatable components of
7635 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7641 stmtblock_t cleanup;
7644 bool sym_has_alloc_comp;
7646 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7647 || sym->ts.type == BT_CLASS)
7648 && sym->ts.u.derived->attr.alloc_comp;
7650 /* Make sure the frontend gets these right. */
7651 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7652 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7653 "allocatable attribute or derived type without allocatable "
7656 gfc_save_backend_locus (&loc);
7657 gfc_set_backend_locus (&sym->declared_at);
7658 gfc_init_block (&init);
7660 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7661 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7663 if (sym->ts.type == BT_CHARACTER
7664 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7666 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7667 gfc_trans_vla_type_sizes (sym, &init);
7670 /* Dummy, use associated and result variables don't need anything special. */
7671 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7673 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7674 gfc_restore_backend_locus (&loc);
7678 descriptor = sym->backend_decl;
7680 /* Although static, derived types with default initializers and
7681 allocatable components must not be nulled wholesale; instead they
7682 are treated component by component. */
7683 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7685 /* SAVEd variables are not freed on exit. */
7686 gfc_trans_static_array_pointer (sym);
7688 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7689 gfc_restore_backend_locus (&loc);
7693 /* Get the descriptor type. */
7694 type = TREE_TYPE (sym->backend_decl);
7696 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7699 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7701 if (sym->value == NULL
7702 || !gfc_has_default_initializer (sym->ts.u.derived))
7704 rank = sym->as ? sym->as->rank : 0;
7705 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7707 gfc_add_expr_to_block (&init, tmp);
7710 gfc_init_default_dt (sym, &init, false);
7713 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7715 /* If the backend_decl is not a descriptor, we must have a pointer
7717 descriptor = build_fold_indirect_ref_loc (input_location,
7719 type = TREE_TYPE (descriptor);
7722 /* NULLIFY the data pointer. */
7723 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7724 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7726 gfc_restore_backend_locus (&loc);
7727 gfc_init_block (&cleanup);
7729 /* Allocatable arrays need to be freed when they go out of scope.
7730 The allocatable components of pointers must not be touched. */
7731 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7732 && !sym->attr.pointer && !sym->attr.save)
7735 rank = sym->as ? sym->as->rank : 0;
7736 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7737 gfc_add_expr_to_block (&cleanup, tmp);
7740 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7741 && !sym->attr.save && !sym->attr.result)
7743 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7744 gfc_add_expr_to_block (&cleanup, tmp);
7747 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7748 gfc_finish_block (&cleanup));
7751 /************ Expression Walking Functions ******************/
7753 /* Walk a variable reference.
7755 Possible extension - multiple component subscripts.
7756 x(:,:) = foo%a(:)%b(:)
7758 forall (i=..., j=...)
7759 x(i,j) = foo%a(j)%b(i)
7761 This adds a fair amount of complexity because you need to deal with more
7762 than one ref. Maybe handle in a similar manner to vector subscripts.
7763 Maybe not worth the effort. */
7767 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7771 for (ref = expr->ref; ref; ref = ref->next)
7772 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7775 return gfc_walk_array_ref (ss, expr, ref);
7780 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
7786 for (; ref; ref = ref->next)
7788 if (ref->type == REF_SUBSTRING)
7790 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
7791 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
7794 /* We're only interested in array sections from now on. */
7795 if (ref->type != REF_ARRAY)
7803 for (n = ar->dimen - 1; n >= 0; n--)
7804 ss = gfc_get_scalar_ss (ss, ar->start[n]);
7808 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
7809 newss->info->data.array.ref = ref;
7811 /* Make sure array is the same as array(:,:), this way
7812 we don't need to special case all the time. */
7813 ar->dimen = ar->as->rank;
7814 for (n = 0; n < ar->dimen; n++)
7816 ar->dimen_type[n] = DIMEN_RANGE;
7818 gcc_assert (ar->start[n] == NULL);
7819 gcc_assert (ar->end[n] == NULL);
7820 gcc_assert (ar->stride[n] == NULL);
7826 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
7827 newss->info->data.array.ref = ref;
7829 /* We add SS chains for all the subscripts in the section. */
7830 for (n = 0; n < ar->dimen; n++)
7834 switch (ar->dimen_type[n])
7837 /* Add SS for elemental (scalar) subscripts. */
7838 gcc_assert (ar->start[n]);
7839 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
7840 indexss->loop_chain = gfc_ss_terminator;
7841 newss->info->data.array.subscript[n] = indexss;
7845 /* We don't add anything for sections, just remember this
7846 dimension for later. */
7847 newss->dim[newss->dimen] = n;
7852 /* Create a GFC_SS_VECTOR index in which we can store
7853 the vector's descriptor. */
7854 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
7856 indexss->loop_chain = gfc_ss_terminator;
7857 newss->info->data.array.subscript[n] = indexss;
7858 newss->dim[newss->dimen] = n;
7863 /* We should know what sort of section it is by now. */
7867 /* We should have at least one non-elemental dimension,
7868 unless we are creating a descriptor for a (scalar) coarray. */
7869 gcc_assert (newss->dimen > 0
7870 || newss->info->data.array.ref->u.ar.as->corank > 0);
7875 /* We should know what sort of section it is by now. */
7884 /* Walk an expression operator. If only one operand of a binary expression is
7885 scalar, we must also add the scalar term to the SS chain. */
7888 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7893 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7894 if (expr->value.op.op2 == NULL)
7897 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7899 /* All operands are scalar. Pass back and let the caller deal with it. */
7903 /* All operands require scalarization. */
7904 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7907 /* One of the operands needs scalarization, the other is scalar.
7908 Create a gfc_ss for the scalar expression. */
7911 /* First operand is scalar. We build the chain in reverse order, so
7912 add the scalar SS after the second operand. */
7914 while (head && head->next != ss)
7916 /* Check we haven't somehow broken the chain. */
7918 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
7920 else /* head2 == head */
7922 gcc_assert (head2 == head);
7923 /* Second operand is scalar. */
7924 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
7931 /* Reverse a SS chain. */
7934 gfc_reverse_ss (gfc_ss * ss)
7939 gcc_assert (ss != NULL);
7941 head = gfc_ss_terminator;
7942 while (ss != gfc_ss_terminator)
7945 /* Check we didn't somehow break the chain. */
7946 gcc_assert (next != NULL);
7956 /* Walk the arguments of an elemental function. */
7959 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7967 head = gfc_ss_terminator;
7970 for (; arg; arg = arg->next)
7975 newss = gfc_walk_subexpr (head, arg->expr);
7978 /* Scalar argument. */
7979 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
7980 newss = gfc_get_scalar_ss (head, arg->expr);
7981 newss->info->type = type;
7990 while (tail->next != gfc_ss_terminator)
7997 /* If all the arguments are scalar we don't need the argument SS. */
7998 gfc_free_ss_chain (head);
8003 /* Add it onto the existing chain. */
8009 /* Walk a function call. Scalar functions are passed back, and taken out of
8010 scalarization loops. For elemental functions we walk their arguments.
8011 The result of functions returning arrays is stored in a temporary outside
8012 the loop, so that the function is only called once. Hence we do not need
8013 to walk their arguments. */
8016 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
8018 gfc_intrinsic_sym *isym;
8020 gfc_component *comp = NULL;
8022 isym = expr->value.function.isym;
8024 /* Handle intrinsic functions separately. */
8026 return gfc_walk_intrinsic_function (ss, expr, isym);
8028 sym = expr->value.function.esym;
8030 sym = expr->symtree->n.sym;
8032 /* A function that returns arrays. */
8033 gfc_is_proc_ptr_comp (expr, &comp);
8034 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
8035 || (comp && comp->attr.dimension))
8036 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
8038 /* Walk the parameters of an elemental function. For now we always pass
8040 if (sym->attr.elemental)
8041 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8044 /* Scalar functions are OK as these are evaluated outside the scalarization
8045 loop. Pass back and let the caller deal with it. */
8050 /* An array temporary is constructed for array constructors. */
8053 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
8055 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
8059 /* Walk an expression. Add walked expressions to the head of the SS chain.
8060 A wholly scalar expression will not be added. */
8063 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
8067 switch (expr->expr_type)
8070 head = gfc_walk_variable_expr (ss, expr);
8074 head = gfc_walk_op_expr (ss, expr);
8078 head = gfc_walk_function_expr (ss, expr);
8083 case EXPR_STRUCTURE:
8084 /* Pass back and let the caller deal with it. */
8088 head = gfc_walk_array_constructor (ss, expr);
8091 case EXPR_SUBSTRING:
8092 /* Pass back and let the caller deal with it. */
8096 internal_error ("bad expression type during walk (%d)",
8103 /* Entry point for expression walking.
8104 A return value equal to the passed chain means this is
8105 a scalar expression. It is up to the caller to take whatever action is
8106 necessary to translate these. */
8109 gfc_walk_expr (gfc_expr * expr)
8113 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
8114 return gfc_reverse_ss (res);