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;
470 /* Free a gfc_ss chain. */
473 gfc_free_ss_chain (gfc_ss * ss)
477 while (ss != gfc_ss_terminator)
479 gcc_assert (ss != NULL);
488 free_ss_info (gfc_ss_info *ss_info)
491 if (ss_info->refcount > 0)
494 gcc_assert (ss_info->refcount == 0);
502 gfc_free_ss (gfc_ss * ss)
504 gfc_ss_info *ss_info;
509 switch (ss_info->type)
512 for (n = 0; n < ss->dimen; n++)
514 if (ss_info->data.array.subscript[ss->dim[n]])
515 gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
523 free_ss_info (ss_info);
528 /* Creates and initializes an array type gfc_ss struct. */
531 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
534 gfc_ss_info *ss_info;
537 ss_info = gfc_get_ss_info ();
539 ss_info->type = type;
540 ss_info->expr = expr;
546 for (i = 0; i < ss->dimen; i++)
553 /* Creates and initializes a temporary type gfc_ss struct. */
556 gfc_get_temp_ss (tree type, tree string_length, int dimen)
559 gfc_ss_info *ss_info;
562 ss_info = gfc_get_ss_info ();
564 ss_info->type = GFC_SS_TEMP;
565 ss_info->string_length = string_length;
566 ss_info->data.temp.type = type;
570 ss->next = gfc_ss_terminator;
572 for (i = 0; i < ss->dimen; i++)
579 /* Creates and initializes a scalar type gfc_ss struct. */
582 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
585 gfc_ss_info *ss_info;
587 ss_info = gfc_get_ss_info ();
589 ss_info->type = GFC_SS_SCALAR;
590 ss_info->expr = expr;
600 /* Free all the SS associated with a loop. */
603 gfc_cleanup_loop (gfc_loopinfo * loop)
605 gfc_loopinfo *loop_next, **ploop;
610 while (ss != gfc_ss_terminator)
612 gcc_assert (ss != NULL);
613 next = ss->loop_chain;
618 /* Remove reference to self in the parent loop. */
620 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
627 /* Free non-freed nested loops. */
628 for (loop = loop->nested; loop; loop = loop_next)
630 loop_next = loop->next;
631 gfc_cleanup_loop (loop);
638 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
642 for (; ss != gfc_ss_terminator; ss = ss->next)
646 if (ss->info->type == GFC_SS_SCALAR
647 || ss->info->type == GFC_SS_REFERENCE
648 || ss->info->type == GFC_SS_TEMP)
651 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
652 if (ss->info->data.array.subscript[n] != NULL)
653 set_ss_loop (ss->info->data.array.subscript[n], loop);
658 /* Associate a SS chain with a loop. */
661 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
664 gfc_loopinfo *nested_loop;
666 if (head == gfc_ss_terminator)
669 set_ss_loop (head, loop);
672 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
676 nested_loop = ss->nested_ss->loop;
678 /* More than one ss can belong to the same loop. Hence, we add the
679 loop to the chain only if it is different from the previously
680 added one, to avoid duplicate nested loops. */
681 if (nested_loop != loop->nested)
683 gcc_assert (nested_loop->parent == NULL);
684 nested_loop->parent = loop;
686 gcc_assert (nested_loop->next == NULL);
687 nested_loop->next = loop->nested;
688 loop->nested = nested_loop;
691 gcc_assert (nested_loop->parent == loop);
694 if (ss->next == gfc_ss_terminator)
695 ss->loop_chain = loop->ss;
697 ss->loop_chain = ss->next;
699 gcc_assert (ss == gfc_ss_terminator);
704 /* Generate an initializer for a static pointer or allocatable array. */
707 gfc_trans_static_array_pointer (gfc_symbol * sym)
711 gcc_assert (TREE_STATIC (sym->backend_decl));
712 /* Just zero the data member. */
713 type = TREE_TYPE (sym->backend_decl);
714 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
718 /* If the bounds of SE's loop have not yet been set, see if they can be
719 determined from array spec AS, which is the array spec of a called
720 function. MAPPING maps the callee's dummy arguments to the values
721 that the caller is passing. Add any initialization and finalization
725 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
726 gfc_se * se, gfc_array_spec * as)
728 int n, dim, total_dim;
737 if (!as || as->type != AS_EXPLICIT)
740 for (ss = se->ss; ss; ss = ss->parent)
742 total_dim += ss->loop->dimen;
743 for (n = 0; n < ss->loop->dimen; n++)
745 /* The bound is known, nothing to do. */
746 if (ss->loop->to[n] != NULL_TREE)
750 gcc_assert (dim < as->rank);
751 gcc_assert (ss->loop->dimen <= as->rank);
753 /* Evaluate the lower bound. */
754 gfc_init_se (&tmpse, NULL);
755 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
756 gfc_add_block_to_block (&se->pre, &tmpse.pre);
757 gfc_add_block_to_block (&se->post, &tmpse.post);
758 lower = fold_convert (gfc_array_index_type, tmpse.expr);
760 /* ...and the upper bound. */
761 gfc_init_se (&tmpse, NULL);
762 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
763 gfc_add_block_to_block (&se->pre, &tmpse.pre);
764 gfc_add_block_to_block (&se->post, &tmpse.post);
765 upper = fold_convert (gfc_array_index_type, tmpse.expr);
767 /* Set the upper bound of the loop to UPPER - LOWER. */
768 tmp = fold_build2_loc (input_location, MINUS_EXPR,
769 gfc_array_index_type, upper, lower);
770 tmp = gfc_evaluate_now (tmp, &se->pre);
771 ss->loop->to[n] = tmp;
775 gcc_assert (total_dim == as->rank);
779 /* Generate code to allocate an array temporary, or create a variable to
780 hold the data. If size is NULL, zero the descriptor so that the
781 callee will allocate the array. If DEALLOC is true, also generate code to
782 free the array afterwards.
784 If INITIAL is not NULL, it is packed using internal_pack and the result used
785 as data instead of allocating a fresh, unitialized area of memory.
787 Initialization code is added to PRE and finalization code to POST.
788 DYNAMIC is true if the caller may want to extend the array later
789 using realloc. This prevents us from putting the array on the stack. */
792 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
793 gfc_array_info * info, tree size, tree nelem,
794 tree initial, bool dynamic, bool dealloc)
800 desc = info->descriptor;
801 info->offset = gfc_index_zero_node;
802 if (size == NULL_TREE || integer_zerop (size))
804 /* A callee allocated array. */
805 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
810 /* Allocate the temporary. */
811 onstack = !dynamic && initial == NULL_TREE
812 && (gfc_option.flag_stack_arrays
813 || gfc_can_put_var_on_stack (size));
817 /* Make a temporary variable to hold the data. */
818 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
819 nelem, gfc_index_one_node);
820 tmp = gfc_evaluate_now (tmp, pre);
821 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
823 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
825 tmp = gfc_create_var (tmp, "A");
826 /* If we're here only because of -fstack-arrays we have to
827 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
828 if (!gfc_can_put_var_on_stack (size))
829 gfc_add_expr_to_block (pre,
830 fold_build1_loc (input_location,
831 DECL_EXPR, TREE_TYPE (tmp),
833 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
834 gfc_conv_descriptor_data_set (pre, desc, tmp);
838 /* Allocate memory to hold the data or call internal_pack. */
839 if (initial == NULL_TREE)
841 tmp = gfc_call_malloc (pre, NULL, size);
842 tmp = gfc_evaluate_now (tmp, pre);
849 stmtblock_t do_copying;
851 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
852 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
853 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
854 tmp = gfc_get_element_type (tmp);
855 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
856 packed = gfc_create_var (build_pointer_type (tmp), "data");
858 tmp = build_call_expr_loc (input_location,
859 gfor_fndecl_in_pack, 1, initial);
860 tmp = fold_convert (TREE_TYPE (packed), tmp);
861 gfc_add_modify (pre, packed, tmp);
863 tmp = build_fold_indirect_ref_loc (input_location,
865 source_data = gfc_conv_descriptor_data_get (tmp);
867 /* internal_pack may return source->data without any allocation
868 or copying if it is already packed. If that's the case, we
869 need to allocate and copy manually. */
871 gfc_start_block (&do_copying);
872 tmp = gfc_call_malloc (&do_copying, NULL, size);
873 tmp = fold_convert (TREE_TYPE (packed), tmp);
874 gfc_add_modify (&do_copying, packed, tmp);
875 tmp = gfc_build_memcpy_call (packed, source_data, size);
876 gfc_add_expr_to_block (&do_copying, tmp);
878 was_packed = fold_build2_loc (input_location, EQ_EXPR,
879 boolean_type_node, packed,
881 tmp = gfc_finish_block (&do_copying);
882 tmp = build3_v (COND_EXPR, was_packed, tmp,
883 build_empty_stmt (input_location));
884 gfc_add_expr_to_block (pre, tmp);
886 tmp = fold_convert (pvoid_type_node, packed);
889 gfc_conv_descriptor_data_set (pre, desc, tmp);
892 info->data = gfc_conv_descriptor_data_get (desc);
894 /* The offset is zero because we create temporaries with a zero
896 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
898 if (dealloc && !onstack)
900 /* Free the temporary. */
901 tmp = gfc_conv_descriptor_data_get (desc);
902 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
903 gfc_add_expr_to_block (post, tmp);
908 /* Get the scalarizer array dimension corresponding to actual array dimension
911 For example, if SS represents the array ref a(1,:,:,1), it is a
912 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
913 and 1 for ARRAY_DIM=2.
914 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
915 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
917 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
918 array. If called on the inner ss, the result would be respectively 0,1,2 for
919 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
920 for ARRAY_DIM=1,2. */
923 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
930 for (; ss; ss = ss->parent)
931 for (n = 0; n < ss->dimen; n++)
932 if (ss->dim[n] < array_dim)
935 return array_ref_dim;
940 innermost_ss (gfc_ss *ss)
942 while (ss->nested_ss != NULL)
950 /* Get the array reference dimension corresponding to the given loop dimension.
951 It is different from the true array dimension given by the dim array in
952 the case of a partial array reference (i.e. a(:,:,1,:) for example)
953 It is different from the loop dimension in the case of a transposed array.
957 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
959 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
964 /* Generate code to create and initialize the descriptor for a temporary
965 array. This is used for both temporaries needed by the scalarizer, and
966 functions returning arrays. Adjusts the loop variables to be
967 zero-based, and calculates the loop bounds for callee allocated arrays.
968 Allocate the array unless it's callee allocated (we have a callee
969 allocated array if 'callee_alloc' is true, or if loop->to[n] is
970 NULL_TREE for any n). Also fills in the descriptor, data and offset
971 fields of info if known. Returns the size of the array, or NULL for a
972 callee allocated array.
974 'eltype' == NULL signals that the temporary should be a class object.
975 The 'initial' expression is used to obtain the size of the dynamic
976 type; otehrwise the allocation and initialisation proceeds as for any
979 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
980 gfc_trans_allocate_array_storage. */
983 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
984 tree eltype, tree initial, bool dynamic,
985 bool dealloc, bool callee_alloc, locus * where)
989 gfc_array_info *info;
990 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
998 tree class_expr = NULL_TREE;
1002 /* This signals a class array for which we need the size of the
1003 dynamic type. Generate an eltype and then the class expression. */
1004 if (eltype == NULL_TREE && initial)
1006 if (POINTER_TYPE_P (TREE_TYPE (initial)))
1007 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1008 eltype = TREE_TYPE (class_expr);
1009 eltype = gfc_get_element_type (eltype);
1010 /* Obtain the structure (class) expression. */
1011 class_expr = TREE_OPERAND (class_expr, 0);
1012 gcc_assert (class_expr);
1015 memset (from, 0, sizeof (from));
1016 memset (to, 0, sizeof (to));
1018 info = &ss->info->data.array;
1020 gcc_assert (ss->dimen > 0);
1021 gcc_assert (ss->loop->dimen == ss->dimen);
1023 if (gfc_option.warn_array_temp && where)
1024 gfc_warning ("Creating array temporary at %L", where);
1026 /* Set the lower bound to zero. */
1027 for (s = ss; s; s = s->parent)
1031 total_dim += loop->dimen;
1032 for (n = 0; n < loop->dimen; n++)
1036 /* Callee allocated arrays may not have a known bound yet. */
1038 loop->to[n] = gfc_evaluate_now (
1039 fold_build2_loc (input_location, MINUS_EXPR,
1040 gfc_array_index_type,
1041 loop->to[n], loop->from[n]),
1043 loop->from[n] = gfc_index_zero_node;
1045 /* We have just changed the loop bounds, we must clear the
1046 corresponding specloop, so that delta calculation is not skipped
1047 later in gfc_set_delta. */
1048 loop->specloop[n] = NULL;
1050 /* We are constructing the temporary's descriptor based on the loop
1051 dimensions. As the dimensions may be accessed in arbitrary order
1052 (think of transpose) the size taken from the n'th loop may not map
1053 to the n'th dimension of the array. We need to reconstruct loop
1054 infos in the right order before using it to set the descriptor
1056 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1057 from[tmp_dim] = loop->from[n];
1058 to[tmp_dim] = loop->to[n];
1060 info->delta[dim] = gfc_index_zero_node;
1061 info->start[dim] = gfc_index_zero_node;
1062 info->end[dim] = gfc_index_zero_node;
1063 info->stride[dim] = gfc_index_one_node;
1067 /* Initialize the descriptor. */
1069 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1070 GFC_ARRAY_UNKNOWN, true);
1071 desc = gfc_create_var (type, "atmp");
1072 GFC_DECL_PACKED_ARRAY (desc) = 1;
1074 info->descriptor = desc;
1075 size = gfc_index_one_node;
1077 /* Fill in the array dtype. */
1078 tmp = gfc_conv_descriptor_dtype (desc);
1079 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1082 Fill in the bounds and stride. This is a packed array, so:
1085 for (n = 0; n < rank; n++)
1088 delta = ubound[n] + 1 - lbound[n];
1089 size = size * delta;
1091 size = size * sizeof(element);
1094 or_expr = NULL_TREE;
1096 /* If there is at least one null loop->to[n], it is a callee allocated
1098 for (n = 0; n < total_dim; n++)
1099 if (to[n] == NULL_TREE)
1105 if (size == NULL_TREE)
1106 for (s = ss; s; s = s->parent)
1107 for (n = 0; n < s->loop->dimen; n++)
1109 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1111 /* For a callee allocated array express the loop bounds in terms
1112 of the descriptor fields. */
1113 tmp = fold_build2_loc (input_location,
1114 MINUS_EXPR, gfc_array_index_type,
1115 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1116 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1117 s->loop->to[n] = tmp;
1121 for (n = 0; n < total_dim; n++)
1123 /* Store the stride and bound components in the descriptor. */
1124 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1126 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1127 gfc_index_zero_node);
1129 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1131 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1132 gfc_array_index_type,
1133 to[n], gfc_index_one_node);
1135 /* Check whether the size for this dimension is negative. */
1136 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1137 tmp, gfc_index_zero_node);
1138 cond = gfc_evaluate_now (cond, pre);
1143 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1144 boolean_type_node, or_expr, cond);
1146 size = fold_build2_loc (input_location, MULT_EXPR,
1147 gfc_array_index_type, size, tmp);
1148 size = gfc_evaluate_now (size, pre);
1152 /* Get the size of the array. */
1153 if (size && !callee_alloc)
1156 /* If or_expr is true, then the extent in at least one
1157 dimension is zero and the size is set to zero. */
1158 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1159 or_expr, gfc_index_zero_node, size);
1162 if (class_expr == NULL_TREE)
1163 elemsize = fold_convert (gfc_array_index_type,
1164 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1166 elemsize = gfc_vtable_size_get (class_expr);
1168 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1177 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1183 if (ss->dimen > ss->loop->temp_dim)
1184 ss->loop->temp_dim = ss->dimen;
1190 /* Return the number of iterations in a loop that starts at START,
1191 ends at END, and has step STEP. */
1194 gfc_get_iteration_count (tree start, tree end, tree step)
1199 type = TREE_TYPE (step);
1200 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1201 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1202 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1203 build_int_cst (type, 1));
1204 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1205 build_int_cst (type, 0));
1206 return fold_convert (gfc_array_index_type, tmp);
1210 /* Extend the data in array DESC by EXTRA elements. */
1213 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1220 if (integer_zerop (extra))
1223 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1225 /* Add EXTRA to the upper bound. */
1226 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1228 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1230 /* Get the value of the current data pointer. */
1231 arg0 = gfc_conv_descriptor_data_get (desc);
1233 /* Calculate the new array size. */
1234 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1235 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1236 ubound, gfc_index_one_node);
1237 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1238 fold_convert (size_type_node, tmp),
1239 fold_convert (size_type_node, size));
1241 /* Call the realloc() function. */
1242 tmp = gfc_call_realloc (pblock, arg0, arg1);
1243 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1247 /* Return true if the bounds of iterator I can only be determined
1251 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1253 return (i->start->expr_type != EXPR_CONSTANT
1254 || i->end->expr_type != EXPR_CONSTANT
1255 || i->step->expr_type != EXPR_CONSTANT);
1259 /* Split the size of constructor element EXPR into the sum of two terms,
1260 one of which can be determined at compile time and one of which must
1261 be calculated at run time. Set *SIZE to the former and return true
1262 if the latter might be nonzero. */
1265 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1267 if (expr->expr_type == EXPR_ARRAY)
1268 return gfc_get_array_constructor_size (size, expr->value.constructor);
1269 else if (expr->rank > 0)
1271 /* Calculate everything at run time. */
1272 mpz_set_ui (*size, 0);
1277 /* A single element. */
1278 mpz_set_ui (*size, 1);
1284 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1285 of array constructor C. */
1288 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1296 mpz_set_ui (*size, 0);
1301 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1304 if (i && gfc_iterator_has_dynamic_bounds (i))
1308 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1311 /* Multiply the static part of the element size by the
1312 number of iterations. */
1313 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1314 mpz_fdiv_q (val, val, i->step->value.integer);
1315 mpz_add_ui (val, val, 1);
1316 if (mpz_sgn (val) > 0)
1317 mpz_mul (len, len, val);
1319 mpz_set_ui (len, 0);
1321 mpz_add (*size, *size, len);
1330 /* Make sure offset is a variable. */
1333 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1336 /* We should have already created the offset variable. We cannot
1337 create it here because we may be in an inner scope. */
1338 gcc_assert (*offsetvar != NULL_TREE);
1339 gfc_add_modify (pblock, *offsetvar, *poffset);
1340 *poffset = *offsetvar;
1341 TREE_USED (*offsetvar) = 1;
1345 /* Variables needed for bounds-checking. */
1346 static bool first_len;
1347 static tree first_len_val;
1348 static bool typespec_chararray_ctor;
1351 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1352 tree offset, gfc_se * se, gfc_expr * expr)
1356 gfc_conv_expr (se, expr);
1358 /* Store the value. */
1359 tmp = build_fold_indirect_ref_loc (input_location,
1360 gfc_conv_descriptor_data_get (desc));
1361 tmp = gfc_build_array_ref (tmp, offset, NULL);
1363 if (expr->ts.type == BT_CHARACTER)
1365 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1368 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1369 esize = fold_convert (gfc_charlen_type_node, esize);
1370 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1371 gfc_charlen_type_node, esize,
1372 build_int_cst (gfc_charlen_type_node,
1373 gfc_character_kinds[i].bit_size / 8));
1375 gfc_conv_string_parameter (se);
1376 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1378 /* The temporary is an array of pointers. */
1379 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1380 gfc_add_modify (&se->pre, tmp, se->expr);
1384 /* The temporary is an array of string values. */
1385 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1386 /* We know the temporary and the value will be the same length,
1387 so can use memcpy. */
1388 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1389 se->string_length, se->expr, expr->ts.kind);
1391 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1395 gfc_add_modify (&se->pre, first_len_val,
1401 /* Verify that all constructor elements are of the same
1403 tree cond = fold_build2_loc (input_location, NE_EXPR,
1404 boolean_type_node, first_len_val,
1406 gfc_trans_runtime_check
1407 (true, false, cond, &se->pre, &expr->where,
1408 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1409 fold_convert (long_integer_type_node, first_len_val),
1410 fold_convert (long_integer_type_node, se->string_length));
1416 /* TODO: Should the frontend already have done this conversion? */
1417 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1418 gfc_add_modify (&se->pre, tmp, se->expr);
1421 gfc_add_block_to_block (pblock, &se->pre);
1422 gfc_add_block_to_block (pblock, &se->post);
1426 /* Add the contents of an array to the constructor. DYNAMIC is as for
1427 gfc_trans_array_constructor_value. */
1430 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1431 tree type ATTRIBUTE_UNUSED,
1432 tree desc, gfc_expr * expr,
1433 tree * poffset, tree * offsetvar,
1444 /* We need this to be a variable so we can increment it. */
1445 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1447 gfc_init_se (&se, NULL);
1449 /* Walk the array expression. */
1450 ss = gfc_walk_expr (expr);
1451 gcc_assert (ss != gfc_ss_terminator);
1453 /* Initialize the scalarizer. */
1454 gfc_init_loopinfo (&loop);
1455 gfc_add_ss_to_loop (&loop, ss);
1457 /* Initialize the loop. */
1458 gfc_conv_ss_startstride (&loop);
1459 gfc_conv_loop_setup (&loop, &expr->where);
1461 /* Make sure the constructed array has room for the new data. */
1464 /* Set SIZE to the total number of elements in the subarray. */
1465 size = gfc_index_one_node;
1466 for (n = 0; n < loop.dimen; n++)
1468 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1469 gfc_index_one_node);
1470 size = fold_build2_loc (input_location, MULT_EXPR,
1471 gfc_array_index_type, size, tmp);
1474 /* Grow the constructed array by SIZE elements. */
1475 gfc_grow_array (&loop.pre, desc, size);
1478 /* Make the loop body. */
1479 gfc_mark_ss_chain_used (ss, 1);
1480 gfc_start_scalarized_body (&loop, &body);
1481 gfc_copy_loopinfo_to_se (&se, &loop);
1484 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1485 gcc_assert (se.ss == gfc_ss_terminator);
1487 /* Increment the offset. */
1488 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1489 *poffset, gfc_index_one_node);
1490 gfc_add_modify (&body, *poffset, tmp);
1492 /* Finish the loop. */
1493 gfc_trans_scalarizing_loops (&loop, &body);
1494 gfc_add_block_to_block (&loop.pre, &loop.post);
1495 tmp = gfc_finish_block (&loop.pre);
1496 gfc_add_expr_to_block (pblock, tmp);
1498 gfc_cleanup_loop (&loop);
1502 /* Assign the values to the elements of an array constructor. DYNAMIC
1503 is true if descriptor DESC only contains enough data for the static
1504 size calculated by gfc_get_array_constructor_size. When true, memory
1505 for the dynamic parts must be allocated using realloc. */
1508 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1509 tree desc, gfc_constructor_base base,
1510 tree * poffset, tree * offsetvar,
1519 tree shadow_loopvar = NULL_TREE;
1520 gfc_saved_var saved_loopvar;
1523 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1525 /* If this is an iterator or an array, the offset must be a variable. */
1526 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1527 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1529 /* Shadowing the iterator avoids changing its value and saves us from
1530 keeping track of it. Further, it makes sure that there's always a
1531 backend-decl for the symbol, even if there wasn't one before,
1532 e.g. in the case of an iterator that appears in a specification
1533 expression in an interface mapping. */
1536 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1537 tree type = gfc_typenode_for_spec (&sym->ts);
1539 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1540 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1543 gfc_start_block (&body);
1545 if (c->expr->expr_type == EXPR_ARRAY)
1547 /* Array constructors can be nested. */
1548 gfc_trans_array_constructor_value (&body, type, desc,
1549 c->expr->value.constructor,
1550 poffset, offsetvar, dynamic);
1552 else if (c->expr->rank > 0)
1554 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1555 poffset, offsetvar, dynamic);
1559 /* This code really upsets the gimplifier so don't bother for now. */
1566 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1568 p = gfc_constructor_next (p);
1573 /* Scalar values. */
1574 gfc_init_se (&se, NULL);
1575 gfc_trans_array_ctor_element (&body, desc, *poffset,
1578 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1579 gfc_array_index_type,
1580 *poffset, gfc_index_one_node);
1584 /* Collect multiple scalar constants into a constructor. */
1585 VEC(constructor_elt,gc) *v = NULL;
1589 HOST_WIDE_INT idx = 0;
1592 /* Count the number of consecutive scalar constants. */
1593 while (p && !(p->iterator
1594 || p->expr->expr_type != EXPR_CONSTANT))
1596 gfc_init_se (&se, NULL);
1597 gfc_conv_constant (&se, p->expr);
1599 if (c->expr->ts.type != BT_CHARACTER)
1600 se.expr = fold_convert (type, se.expr);
1601 /* For constant character array constructors we build
1602 an array of pointers. */
1603 else if (POINTER_TYPE_P (type))
1604 se.expr = gfc_build_addr_expr
1605 (gfc_get_pchar_type (p->expr->ts.kind),
1608 CONSTRUCTOR_APPEND_ELT (v,
1609 build_int_cst (gfc_array_index_type,
1613 p = gfc_constructor_next (p);
1616 bound = size_int (n - 1);
1617 /* Create an array type to hold them. */
1618 tmptype = build_range_type (gfc_array_index_type,
1619 gfc_index_zero_node, bound);
1620 tmptype = build_array_type (type, tmptype);
1622 init = build_constructor (tmptype, v);
1623 TREE_CONSTANT (init) = 1;
1624 TREE_STATIC (init) = 1;
1625 /* Create a static variable to hold the data. */
1626 tmp = gfc_create_var (tmptype, "data");
1627 TREE_STATIC (tmp) = 1;
1628 TREE_CONSTANT (tmp) = 1;
1629 TREE_READONLY (tmp) = 1;
1630 DECL_INITIAL (tmp) = init;
1633 /* Use BUILTIN_MEMCPY to assign the values. */
1634 tmp = gfc_conv_descriptor_data_get (desc);
1635 tmp = build_fold_indirect_ref_loc (input_location,
1637 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1638 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1639 init = gfc_build_addr_expr (NULL_TREE, init);
1641 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1642 bound = build_int_cst (size_type_node, n * size);
1643 tmp = build_call_expr_loc (input_location,
1644 builtin_decl_explicit (BUILT_IN_MEMCPY),
1645 3, tmp, init, bound);
1646 gfc_add_expr_to_block (&body, tmp);
1648 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1649 gfc_array_index_type, *poffset,
1650 build_int_cst (gfc_array_index_type, n));
1652 if (!INTEGER_CST_P (*poffset))
1654 gfc_add_modify (&body, *offsetvar, *poffset);
1655 *poffset = *offsetvar;
1659 /* The frontend should already have done any expansions
1663 /* Pass the code as is. */
1664 tmp = gfc_finish_block (&body);
1665 gfc_add_expr_to_block (pblock, tmp);
1669 /* Build the implied do-loop. */
1670 stmtblock_t implied_do_block;
1678 loopbody = gfc_finish_block (&body);
1680 /* Create a new block that holds the implied-do loop. A temporary
1681 loop-variable is used. */
1682 gfc_start_block(&implied_do_block);
1684 /* Initialize the loop. */
1685 gfc_init_se (&se, NULL);
1686 gfc_conv_expr_val (&se, c->iterator->start);
1687 gfc_add_block_to_block (&implied_do_block, &se.pre);
1688 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1690 gfc_init_se (&se, NULL);
1691 gfc_conv_expr_val (&se, c->iterator->end);
1692 gfc_add_block_to_block (&implied_do_block, &se.pre);
1693 end = gfc_evaluate_now (se.expr, &implied_do_block);
1695 gfc_init_se (&se, NULL);
1696 gfc_conv_expr_val (&se, c->iterator->step);
1697 gfc_add_block_to_block (&implied_do_block, &se.pre);
1698 step = gfc_evaluate_now (se.expr, &implied_do_block);
1700 /* If this array expands dynamically, and the number of iterations
1701 is not constant, we won't have allocated space for the static
1702 part of C->EXPR's size. Do that now. */
1703 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1705 /* Get the number of iterations. */
1706 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1708 /* Get the static part of C->EXPR's size. */
1709 gfc_get_array_constructor_element_size (&size, c->expr);
1710 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1712 /* Grow the array by TMP * TMP2 elements. */
1713 tmp = fold_build2_loc (input_location, MULT_EXPR,
1714 gfc_array_index_type, tmp, tmp2);
1715 gfc_grow_array (&implied_do_block, desc, tmp);
1718 /* Generate the loop body. */
1719 exit_label = gfc_build_label_decl (NULL_TREE);
1720 gfc_start_block (&body);
1722 /* Generate the exit condition. Depending on the sign of
1723 the step variable we have to generate the correct
1725 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1726 step, build_int_cst (TREE_TYPE (step), 0));
1727 cond = fold_build3_loc (input_location, COND_EXPR,
1728 boolean_type_node, tmp,
1729 fold_build2_loc (input_location, GT_EXPR,
1730 boolean_type_node, shadow_loopvar, end),
1731 fold_build2_loc (input_location, LT_EXPR,
1732 boolean_type_node, shadow_loopvar, end));
1733 tmp = build1_v (GOTO_EXPR, exit_label);
1734 TREE_USED (exit_label) = 1;
1735 tmp = build3_v (COND_EXPR, cond, tmp,
1736 build_empty_stmt (input_location));
1737 gfc_add_expr_to_block (&body, tmp);
1739 /* The main loop body. */
1740 gfc_add_expr_to_block (&body, loopbody);
1742 /* Increase loop variable by step. */
1743 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1744 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1746 gfc_add_modify (&body, shadow_loopvar, tmp);
1748 /* Finish the loop. */
1749 tmp = gfc_finish_block (&body);
1750 tmp = build1_v (LOOP_EXPR, tmp);
1751 gfc_add_expr_to_block (&implied_do_block, tmp);
1753 /* Add the exit label. */
1754 tmp = build1_v (LABEL_EXPR, exit_label);
1755 gfc_add_expr_to_block (&implied_do_block, tmp);
1757 /* Finishe the implied-do loop. */
1758 tmp = gfc_finish_block(&implied_do_block);
1759 gfc_add_expr_to_block(pblock, tmp);
1761 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1768 /* A catch-all to obtain the string length for anything that is not a
1769 a substring of non-constant length, a constant, array or variable. */
1772 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1777 /* Don't bother if we already know the length is a constant. */
1778 if (*len && INTEGER_CST_P (*len))
1781 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1782 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1785 gfc_conv_const_charlen (e->ts.u.cl);
1786 *len = e->ts.u.cl->backend_decl;
1790 /* Otherwise, be brutal even if inefficient. */
1791 ss = gfc_walk_expr (e);
1792 gfc_init_se (&se, NULL);
1794 /* No function call, in case of side effects. */
1795 se.no_function_call = 1;
1796 if (ss == gfc_ss_terminator)
1797 gfc_conv_expr (&se, e);
1799 gfc_conv_expr_descriptor (&se, e, ss);
1801 /* Fix the value. */
1802 *len = gfc_evaluate_now (se.string_length, &se.pre);
1804 gfc_add_block_to_block (block, &se.pre);
1805 gfc_add_block_to_block (block, &se.post);
1807 e->ts.u.cl->backend_decl = *len;
1812 /* Figure out the string length of a variable reference expression.
1813 Used by get_array_ctor_strlen. */
1816 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1822 /* Don't bother if we already know the length is a constant. */
1823 if (*len && INTEGER_CST_P (*len))
1826 ts = &expr->symtree->n.sym->ts;
1827 for (ref = expr->ref; ref; ref = ref->next)
1832 /* Array references don't change the string length. */
1836 /* Use the length of the component. */
1837 ts = &ref->u.c.component->ts;
1841 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1842 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1844 /* Note that this might evaluate expr. */
1845 get_array_ctor_all_strlen (block, expr, len);
1848 mpz_init_set_ui (char_len, 1);
1849 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1850 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1851 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1852 *len = convert (gfc_charlen_type_node, *len);
1853 mpz_clear (char_len);
1861 *len = ts->u.cl->backend_decl;
1865 /* Figure out the string length of a character array constructor.
1866 If len is NULL, don't calculate the length; this happens for recursive calls
1867 when a sub-array-constructor is an element but not at the first position,
1868 so when we're not interested in the length.
1869 Returns TRUE if all elements are character constants. */
1872 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1879 if (gfc_constructor_first (base) == NULL)
1882 *len = build_int_cstu (gfc_charlen_type_node, 0);
1886 /* Loop over all constructor elements to find out is_const, but in len we
1887 want to store the length of the first, not the last, element. We can
1888 of course exit the loop as soon as is_const is found to be false. */
1889 for (c = gfc_constructor_first (base);
1890 c && is_const; c = gfc_constructor_next (c))
1892 switch (c->expr->expr_type)
1895 if (len && !(*len && INTEGER_CST_P (*len)))
1896 *len = build_int_cstu (gfc_charlen_type_node,
1897 c->expr->value.character.length);
1901 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1908 get_array_ctor_var_strlen (block, c->expr, len);
1914 get_array_ctor_all_strlen (block, c->expr, len);
1918 /* After the first iteration, we don't want the length modified. */
1925 /* Check whether the array constructor C consists entirely of constant
1926 elements, and if so returns the number of those elements, otherwise
1927 return zero. Note, an empty or NULL array constructor returns zero. */
1929 unsigned HOST_WIDE_INT
1930 gfc_constant_array_constructor_p (gfc_constructor_base base)
1932 unsigned HOST_WIDE_INT nelem = 0;
1934 gfc_constructor *c = gfc_constructor_first (base);
1938 || c->expr->rank > 0
1939 || c->expr->expr_type != EXPR_CONSTANT)
1941 c = gfc_constructor_next (c);
1948 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1949 and the tree type of it's elements, TYPE, return a static constant
1950 variable that is compile-time initialized. */
1953 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1955 tree tmptype, init, tmp;
1956 HOST_WIDE_INT nelem;
1961 VEC(constructor_elt,gc) *v = NULL;
1963 /* First traverse the constructor list, converting the constants
1964 to tree to build an initializer. */
1966 c = gfc_constructor_first (expr->value.constructor);
1969 gfc_init_se (&se, NULL);
1970 gfc_conv_constant (&se, c->expr);
1971 if (c->expr->ts.type != BT_CHARACTER)
1972 se.expr = fold_convert (type, se.expr);
1973 else if (POINTER_TYPE_P (type))
1974 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1976 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1978 c = gfc_constructor_next (c);
1982 /* Next determine the tree type for the array. We use the gfortran
1983 front-end's gfc_get_nodesc_array_type in order to create a suitable
1984 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1986 memset (&as, 0, sizeof (gfc_array_spec));
1988 as.rank = expr->rank;
1989 as.type = AS_EXPLICIT;
1992 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1993 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1997 for (i = 0; i < expr->rank; i++)
1999 int tmp = (int) mpz_get_si (expr->shape[i]);
2000 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2001 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2005 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2007 /* as is not needed anymore. */
2008 for (i = 0; i < as.rank + as.corank; i++)
2010 gfc_free_expr (as.lower[i]);
2011 gfc_free_expr (as.upper[i]);
2014 init = build_constructor (tmptype, v);
2016 TREE_CONSTANT (init) = 1;
2017 TREE_STATIC (init) = 1;
2019 tmp = gfc_create_var (tmptype, "A");
2020 TREE_STATIC (tmp) = 1;
2021 TREE_CONSTANT (tmp) = 1;
2022 TREE_READONLY (tmp) = 1;
2023 DECL_INITIAL (tmp) = init;
2029 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2030 This mostly initializes the scalarizer state info structure with the
2031 appropriate values to directly use the array created by the function
2032 gfc_build_constant_array_constructor. */
2035 trans_constant_array_constructor (gfc_ss * ss, tree type)
2037 gfc_array_info *info;
2041 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2043 info = &ss->info->data.array;
2045 info->descriptor = tmp;
2046 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2047 info->offset = gfc_index_zero_node;
2049 for (i = 0; i < ss->dimen; i++)
2051 info->delta[i] = gfc_index_zero_node;
2052 info->start[i] = gfc_index_zero_node;
2053 info->end[i] = gfc_index_zero_node;
2054 info->stride[i] = gfc_index_one_node;
2060 get_rank (gfc_loopinfo *loop)
2065 for (; loop; loop = loop->parent)
2066 rank += loop->dimen;
2072 /* Helper routine of gfc_trans_array_constructor to determine if the
2073 bounds of the loop specified by LOOP are constant and simple enough
2074 to use with trans_constant_array_constructor. Returns the
2075 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2078 constant_array_constructor_loop_size (gfc_loopinfo * l)
2081 tree size = gfc_index_one_node;
2085 total_dim = get_rank (l);
2087 for (loop = l; loop; loop = loop->parent)
2089 for (i = 0; i < loop->dimen; i++)
2091 /* If the bounds aren't constant, return NULL_TREE. */
2092 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2094 if (!integer_zerop (loop->from[i]))
2096 /* Only allow nonzero "from" in one-dimensional arrays. */
2099 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2100 gfc_array_index_type,
2101 loop->to[i], loop->from[i]);
2105 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2106 gfc_array_index_type, tmp, gfc_index_one_node);
2107 size = fold_build2_loc (input_location, MULT_EXPR,
2108 gfc_array_index_type, size, tmp);
2117 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2122 gcc_assert (array->nested_ss == NULL);
2124 for (ss = array; ss; ss = ss->parent)
2125 for (n = 0; n < ss->loop->dimen; n++)
2126 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2127 return &(ss->loop->to[n]);
2133 static gfc_loopinfo *
2134 outermost_loop (gfc_loopinfo * loop)
2136 while (loop->parent != NULL)
2137 loop = loop->parent;
2143 /* Array constructors are handled by constructing a temporary, then using that
2144 within the scalarization loop. This is not optimal, but seems by far the
2148 trans_array_constructor (gfc_ss * ss, locus * where)
2150 gfc_constructor_base c;
2158 bool old_first_len, old_typespec_chararray_ctor;
2159 tree old_first_len_val;
2160 gfc_loopinfo *loop, *outer_loop;
2161 gfc_ss_info *ss_info;
2165 /* Save the old values for nested checking. */
2166 old_first_len = first_len;
2167 old_first_len_val = first_len_val;
2168 old_typespec_chararray_ctor = typespec_chararray_ctor;
2171 outer_loop = outermost_loop (loop);
2173 expr = ss_info->expr;
2175 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2176 typespec was given for the array constructor. */
2177 typespec_chararray_ctor = (expr->ts.u.cl
2178 && expr->ts.u.cl->length_from_typespec);
2180 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2181 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2183 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2187 gcc_assert (ss->dimen == ss->loop->dimen);
2189 c = expr->value.constructor;
2190 if (expr->ts.type == BT_CHARACTER)
2194 /* get_array_ctor_strlen walks the elements of the constructor, if a
2195 typespec was given, we already know the string length and want the one
2197 if (typespec_chararray_ctor && expr->ts.u.cl->length
2198 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2202 const_string = false;
2203 gfc_init_se (&length_se, NULL);
2204 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2205 gfc_charlen_type_node);
2206 ss_info->string_length = length_se.expr;
2207 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2208 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2211 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2212 &ss_info->string_length);
2214 /* Complex character array constructors should have been taken care of
2215 and not end up here. */
2216 gcc_assert (ss_info->string_length);
2218 expr->ts.u.cl->backend_decl = ss_info->string_length;
2220 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2222 type = build_pointer_type (type);
2225 type = gfc_typenode_for_spec (&expr->ts);
2227 /* See if the constructor determines the loop bounds. */
2230 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2232 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2234 /* We have a multidimensional parameter. */
2235 for (s = ss; s; s = s->parent)
2238 for (n = 0; n < s->loop->dimen; n++)
2240 s->loop->from[n] = gfc_index_zero_node;
2241 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2242 gfc_index_integer_kind);
2243 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2244 gfc_array_index_type,
2246 gfc_index_one_node);
2251 if (*loop_ubound0 == NULL_TREE)
2255 /* We should have a 1-dimensional, zero-based loop. */
2256 gcc_assert (loop->parent == NULL && loop->nested == NULL);
2257 gcc_assert (loop->dimen == 1);
2258 gcc_assert (integer_zerop (loop->from[0]));
2260 /* Split the constructor size into a static part and a dynamic part.
2261 Allocate the static size up-front and record whether the dynamic
2262 size might be nonzero. */
2264 dynamic = gfc_get_array_constructor_size (&size, c);
2265 mpz_sub_ui (size, size, 1);
2266 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2270 /* Special case constant array constructors. */
2273 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2276 tree size = constant_array_constructor_loop_size (loop);
2277 if (size && compare_tree_int (size, nelem) == 0)
2279 trans_constant_array_constructor (ss, type);
2285 if (TREE_CODE (*loop_ubound0) == VAR_DECL)
2288 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2289 NULL_TREE, dynamic, true, false, where);
2291 desc = ss_info->data.array.descriptor;
2292 offset = gfc_index_zero_node;
2293 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2294 TREE_NO_WARNING (offsetvar) = 1;
2295 TREE_USED (offsetvar) = 0;
2296 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
2297 &offset, &offsetvar, dynamic);
2299 /* If the array grows dynamically, the upper bound of the loop variable
2300 is determined by the array's final upper bound. */
2303 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2304 gfc_array_index_type,
2305 offsetvar, gfc_index_one_node);
2306 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2307 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2308 if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
2309 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2311 *loop_ubound0 = tmp;
2314 if (TREE_USED (offsetvar))
2315 pushdecl (offsetvar);
2317 gcc_assert (INTEGER_CST_P (offset));
2320 /* Disable bound checking for now because it's probably broken. */
2321 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2328 /* Restore old values of globals. */
2329 first_len = old_first_len;
2330 first_len_val = old_first_len_val;
2331 typespec_chararray_ctor = old_typespec_chararray_ctor;
2335 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2336 called after evaluating all of INFO's vector dimensions. Go through
2337 each such vector dimension and see if we can now fill in any missing
2341 set_vector_loop_bounds (gfc_ss * ss)
2343 gfc_loopinfo *loop, *outer_loop;
2344 gfc_array_info *info;
2352 outer_loop = outermost_loop (ss->loop);
2354 info = &ss->info->data.array;
2356 for (; ss; ss = ss->parent)
2360 for (n = 0; n < loop->dimen; n++)
2363 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2364 || loop->to[n] != NULL)
2367 /* Loop variable N indexes vector dimension DIM, and we don't
2368 yet know the upper bound of loop variable N. Set it to the
2369 difference between the vector's upper and lower bounds. */
2370 gcc_assert (loop->from[n] == gfc_index_zero_node);
2371 gcc_assert (info->subscript[dim]
2372 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2374 gfc_init_se (&se, NULL);
2375 desc = info->subscript[dim]->info->data.array.descriptor;
2376 zero = gfc_rank_cst[0];
2377 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2378 gfc_array_index_type,
2379 gfc_conv_descriptor_ubound_get (desc, zero),
2380 gfc_conv_descriptor_lbound_get (desc, zero));
2381 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2388 /* Add the pre and post chains for all the scalar expressions in a SS chain
2389 to loop. This is called after the loop parameters have been calculated,
2390 but before the actual scalarizing loops. */
2393 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2396 gfc_loopinfo *nested_loop, *outer_loop;
2398 gfc_ss_info *ss_info;
2399 gfc_array_info *info;
2403 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2404 arguments could get evaluated multiple times. */
2405 if (ss->is_alloc_lhs)
2408 /* TODO: This can generate bad code if there are ordering dependencies,
2409 e.g., a callee allocated function and an unknown size constructor. */
2410 gcc_assert (ss != NULL);
2412 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2416 /* Cross loop arrays are handled from within the most nested loop. */
2417 if (ss->nested_ss != NULL)
2421 expr = ss_info->expr;
2422 info = &ss_info->data.array;
2424 switch (ss_info->type)
2427 /* Scalar expression. Evaluate this now. This includes elemental
2428 dimension indices, but not array section bounds. */
2429 gfc_init_se (&se, NULL);
2430 gfc_conv_expr (&se, expr);
2431 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2433 if (expr->ts.type != BT_CHARACTER)
2435 /* Move the evaluation of scalar expressions outside the
2436 scalarization loop, except for WHERE assignments. */
2438 se.expr = convert(gfc_array_index_type, se.expr);
2439 if (!ss_info->where)
2440 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2441 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2444 gfc_add_block_to_block (&outer_loop->post, &se.post);
2446 ss_info->data.scalar.value = se.expr;
2447 ss_info->string_length = se.string_length;
2450 case GFC_SS_REFERENCE:
2451 /* Scalar argument to elemental procedure. */
2452 gfc_init_se (&se, NULL);
2453 if (ss_info->data.scalar.can_be_null_ref)
2455 /* If the actual argument can be absent (in other words, it can
2456 be a NULL reference), don't try to evaluate it; pass instead
2457 the reference directly. */
2458 gfc_conv_expr_reference (&se, expr);
2462 /* Otherwise, evaluate the argument outside the loop and pass
2463 a reference to the value. */
2464 gfc_conv_expr (&se, expr);
2466 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2467 gfc_add_block_to_block (&outer_loop->post, &se.post);
2468 if (gfc_is_class_scalar_expr (expr))
2469 /* This is necessary because the dynamic type will always be
2470 large than the declared type. In consequence, assigning
2471 the value to a temporary could segfault.
2472 OOP-TODO: see if this is generally correct or is the value
2473 has to be written to an allocated temporary, whose address
2474 is passed via ss_info. */
2475 ss_info->data.scalar.value = se.expr;
2477 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2480 ss_info->string_length = se.string_length;
2483 case GFC_SS_SECTION:
2484 /* Add the expressions for scalar and vector subscripts. */
2485 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2486 if (info->subscript[n])
2487 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2489 set_vector_loop_bounds (ss);
2493 /* Get the vector's descriptor and store it in SS. */
2494 gfc_init_se (&se, NULL);
2495 gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2496 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2497 gfc_add_block_to_block (&outer_loop->post, &se.post);
2498 info->descriptor = se.expr;
2501 case GFC_SS_INTRINSIC:
2502 gfc_add_intrinsic_ss_code (loop, ss);
2505 case GFC_SS_FUNCTION:
2506 /* Array function return value. We call the function and save its
2507 result in a temporary for use inside the loop. */
2508 gfc_init_se (&se, NULL);
2511 gfc_conv_expr (&se, expr);
2512 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2513 gfc_add_block_to_block (&outer_loop->post, &se.post);
2514 ss_info->string_length = se.string_length;
2517 case GFC_SS_CONSTRUCTOR:
2518 if (expr->ts.type == BT_CHARACTER
2519 && ss_info->string_length == NULL
2521 && expr->ts.u.cl->length)
2523 gfc_init_se (&se, NULL);
2524 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2525 gfc_charlen_type_node);
2526 ss_info->string_length = se.expr;
2527 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2528 gfc_add_block_to_block (&outer_loop->post, &se.post);
2530 trans_array_constructor (ss, where);
2534 case GFC_SS_COMPONENT:
2535 /* Do nothing. These are handled elsewhere. */
2544 for (nested_loop = loop->nested; nested_loop;
2545 nested_loop = nested_loop->next)
2546 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2550 /* Translate expressions for the descriptor and data pointer of a SS. */
2554 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2557 gfc_ss_info *ss_info;
2558 gfc_array_info *info;
2562 info = &ss_info->data.array;
2564 /* Get the descriptor for the array to be scalarized. */
2565 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2566 gfc_init_se (&se, NULL);
2567 se.descriptor_only = 1;
2568 gfc_conv_expr_lhs (&se, ss_info->expr);
2569 gfc_add_block_to_block (block, &se.pre);
2570 info->descriptor = se.expr;
2571 ss_info->string_length = se.string_length;
2575 /* Also the data pointer. */
2576 tmp = gfc_conv_array_data (se.expr);
2577 /* If this is a variable or address of a variable we use it directly.
2578 Otherwise we must evaluate it now to avoid breaking dependency
2579 analysis by pulling the expressions for elemental array indices
2582 || (TREE_CODE (tmp) == ADDR_EXPR
2583 && DECL_P (TREE_OPERAND (tmp, 0)))))
2584 tmp = gfc_evaluate_now (tmp, block);
2587 tmp = gfc_conv_array_offset (se.expr);
2588 info->offset = gfc_evaluate_now (tmp, block);
2590 /* Make absolutely sure that the saved_offset is indeed saved
2591 so that the variable is still accessible after the loops
2593 info->saved_offset = info->offset;
2598 /* Initialize a gfc_loopinfo structure. */
2601 gfc_init_loopinfo (gfc_loopinfo * loop)
2605 memset (loop, 0, sizeof (gfc_loopinfo));
2606 gfc_init_block (&loop->pre);
2607 gfc_init_block (&loop->post);
2609 /* Initially scalarize in order and default to no loop reversal. */
2610 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2613 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2616 loop->ss = gfc_ss_terminator;
2620 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2624 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2630 /* Return an expression for the data pointer of an array. */
2633 gfc_conv_array_data (tree descriptor)
2637 type = TREE_TYPE (descriptor);
2638 if (GFC_ARRAY_TYPE_P (type))
2640 if (TREE_CODE (type) == POINTER_TYPE)
2644 /* Descriptorless arrays. */
2645 return gfc_build_addr_expr (NULL_TREE, descriptor);
2649 return gfc_conv_descriptor_data_get (descriptor);
2653 /* Return an expression for the base offset of an array. */
2656 gfc_conv_array_offset (tree descriptor)
2660 type = TREE_TYPE (descriptor);
2661 if (GFC_ARRAY_TYPE_P (type))
2662 return GFC_TYPE_ARRAY_OFFSET (type);
2664 return gfc_conv_descriptor_offset_get (descriptor);
2668 /* Get an expression for the array stride. */
2671 gfc_conv_array_stride (tree descriptor, int dim)
2676 type = TREE_TYPE (descriptor);
2678 /* For descriptorless arrays use the array size. */
2679 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2680 if (tmp != NULL_TREE)
2683 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2688 /* Like gfc_conv_array_stride, but for the lower bound. */
2691 gfc_conv_array_lbound (tree descriptor, int dim)
2696 type = TREE_TYPE (descriptor);
2698 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2699 if (tmp != NULL_TREE)
2702 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2707 /* Like gfc_conv_array_stride, but for the upper bound. */
2710 gfc_conv_array_ubound (tree descriptor, int dim)
2715 type = TREE_TYPE (descriptor);
2717 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2718 if (tmp != NULL_TREE)
2721 /* This should only ever happen when passing an assumed shape array
2722 as an actual parameter. The value will never be used. */
2723 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2724 return gfc_index_zero_node;
2726 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2731 /* Generate code to perform an array index bound check. */
2734 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2735 locus * where, bool check_upper)
2738 tree tmp_lo, tmp_up;
2741 const char * name = NULL;
2743 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2746 descriptor = ss->info->data.array.descriptor;
2748 index = gfc_evaluate_now (index, &se->pre);
2750 /* We find a name for the error message. */
2751 name = ss->info->expr->symtree->n.sym->name;
2752 gcc_assert (name != NULL);
2754 if (TREE_CODE (descriptor) == VAR_DECL)
2755 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2757 /* If upper bound is present, include both bounds in the error message. */
2760 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2761 tmp_up = gfc_conv_array_ubound (descriptor, n);
2764 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2765 "outside of expected range (%%ld:%%ld)", n+1, name);
2767 asprintf (&msg, "Index '%%ld' of dimension %d "
2768 "outside of expected range (%%ld:%%ld)", n+1);
2770 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2772 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2773 fold_convert (long_integer_type_node, index),
2774 fold_convert (long_integer_type_node, tmp_lo),
2775 fold_convert (long_integer_type_node, tmp_up));
2776 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2778 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2779 fold_convert (long_integer_type_node, index),
2780 fold_convert (long_integer_type_node, tmp_lo),
2781 fold_convert (long_integer_type_node, tmp_up));
2786 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2789 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2790 "below lower bound of %%ld", n+1, name);
2792 asprintf (&msg, "Index '%%ld' of dimension %d "
2793 "below lower bound of %%ld", n+1);
2795 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2797 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2798 fold_convert (long_integer_type_node, index),
2799 fold_convert (long_integer_type_node, tmp_lo));
2807 /* Return the offset for an index. Performs bound checking for elemental
2808 dimensions. Single element references are processed separately.
2809 DIM is the array dimension, I is the loop dimension. */
2812 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2813 gfc_array_ref * ar, tree stride)
2815 gfc_array_info *info;
2820 info = &ss->info->data.array;
2822 /* Get the index into the array for this dimension. */
2825 gcc_assert (ar->type != AR_ELEMENT);
2826 switch (ar->dimen_type[dim])
2828 case DIMEN_THIS_IMAGE:
2832 /* Elemental dimension. */
2833 gcc_assert (info->subscript[dim]
2834 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2835 /* We've already translated this value outside the loop. */
2836 index = info->subscript[dim]->info->data.scalar.value;
2838 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2839 ar->as->type != AS_ASSUMED_SIZE
2840 || dim < ar->dimen - 1);
2844 gcc_assert (info && se->loop);
2845 gcc_assert (info->subscript[dim]
2846 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2847 desc = info->subscript[dim]->info->data.array.descriptor;
2849 /* Get a zero-based index into the vector. */
2850 index = fold_build2_loc (input_location, MINUS_EXPR,
2851 gfc_array_index_type,
2852 se->loop->loopvar[i], se->loop->from[i]);
2854 /* Multiply the index by the stride. */
2855 index = fold_build2_loc (input_location, MULT_EXPR,
2856 gfc_array_index_type,
2857 index, gfc_conv_array_stride (desc, 0));
2859 /* Read the vector to get an index into info->descriptor. */
2860 data = build_fold_indirect_ref_loc (input_location,
2861 gfc_conv_array_data (desc));
2862 index = gfc_build_array_ref (data, index, NULL);
2863 index = gfc_evaluate_now (index, &se->pre);
2864 index = fold_convert (gfc_array_index_type, index);
2866 /* Do any bounds checking on the final info->descriptor index. */
2867 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2868 ar->as->type != AS_ASSUMED_SIZE
2869 || dim < ar->dimen - 1);
2873 /* Scalarized dimension. */
2874 gcc_assert (info && se->loop);
2876 /* Multiply the loop variable by the stride and delta. */
2877 index = se->loop->loopvar[i];
2878 if (!integer_onep (info->stride[dim]))
2879 index = fold_build2_loc (input_location, MULT_EXPR,
2880 gfc_array_index_type, index,
2882 if (!integer_zerop (info->delta[dim]))
2883 index = fold_build2_loc (input_location, PLUS_EXPR,
2884 gfc_array_index_type, index,
2894 /* Temporary array or derived type component. */
2895 gcc_assert (se->loop);
2896 index = se->loop->loopvar[se->loop->order[i]];
2898 /* Pointer functions can have stride[0] different from unity.
2899 Use the stride returned by the function call and stored in
2900 the descriptor for the temporary. */
2901 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2902 && se->ss->info->expr
2903 && se->ss->info->expr->symtree
2904 && se->ss->info->expr->symtree->n.sym->result
2905 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2906 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2909 if (!integer_zerop (info->delta[dim]))
2910 index = fold_build2_loc (input_location, PLUS_EXPR,
2911 gfc_array_index_type, index, info->delta[dim]);
2914 /* Multiply by the stride. */
2915 if (!integer_onep (stride))
2916 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2923 /* Build a scalarized array reference using the vptr 'size'. */
2926 build_class_array_ref (gfc_se *se, tree base, tree index)
2933 gfc_expr *expr = se->ss->info->expr;
2938 if (expr == NULL || expr->ts.type != BT_CLASS)
2941 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
2942 ts = &expr->symtree->n.sym->ts;
2947 for (ref = expr->ref; ref; ref = ref->next)
2949 if (ref->type == REF_COMPONENT
2950 && ref->u.c.component->ts.type == BT_CLASS
2951 && ref->next && ref->next->type == REF_COMPONENT
2952 && strcmp (ref->next->u.c.component->name, "_data") == 0
2954 && ref->next->next->type == REF_ARRAY
2955 && ref->next->next->u.ar.type != AR_ELEMENT)
2957 ts = &ref->u.c.component->ts;
2966 if (class_ref == NULL)
2967 decl = expr->symtree->n.sym->backend_decl;
2970 /* Remove everything after the last class reference, convert the
2971 expression and then recover its tailend once more. */
2973 ref = class_ref->next;
2974 class_ref->next = NULL;
2975 gfc_init_se (&tmpse, NULL);
2976 gfc_conv_expr (&tmpse, expr);
2978 class_ref->next = ref;
2981 size = gfc_vtable_size_get (decl);
2983 /* Build the address of the element. */
2984 type = TREE_TYPE (TREE_TYPE (base));
2985 size = fold_convert (TREE_TYPE (index), size);
2986 offset = fold_build2_loc (input_location, MULT_EXPR,
2987 gfc_array_index_type,
2989 tmp = gfc_build_addr_expr (pvoid_type_node, base);
2990 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
2991 tmp = fold_convert (build_pointer_type (type), tmp);
2993 /* Return the element in the se expression. */
2994 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
2999 /* Build a scalarized reference to an array. */
3002 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3004 gfc_array_info *info;
3005 tree decl = NULL_TREE;
3013 expr = ss->info->expr;
3014 info = &ss->info->data.array;
3016 n = se->loop->order[0];
3020 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3021 /* Add the offset for this dimension to the stored offset for all other
3023 if (!integer_zerop (info->offset))
3024 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3025 index, info->offset);
3027 if (expr && is_subref_array (expr))
3028 decl = expr->symtree->n.sym->backend_decl;
3030 tmp = build_fold_indirect_ref_loc (input_location, info->data);
3032 /* Use the vptr 'size' field to access a class the element of a class
3034 if (build_class_array_ref (se, tmp, index))
3037 se->expr = gfc_build_array_ref (tmp, index, decl);
3041 /* Translate access of temporary array. */
3044 gfc_conv_tmp_array_ref (gfc_se * se)
3046 se->string_length = se->ss->info->string_length;
3047 gfc_conv_scalarized_array_ref (se, NULL);
3048 gfc_advance_se_ss_chain (se);
3051 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3054 add_to_offset (tree *cst_offset, tree *offset, tree t)
3056 if (TREE_CODE (t) == INTEGER_CST)
3057 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3060 if (!integer_zerop (*offset))
3061 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3062 gfc_array_index_type, *offset, t);
3068 /* Build an array reference. se->expr already holds the array descriptor.
3069 This should be either a variable, indirect variable reference or component
3070 reference. For arrays which do not have a descriptor, se->expr will be
3072 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3075 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
3079 tree offset, cst_offset;
3087 gcc_assert (ar->codimen);
3089 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3090 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3093 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3094 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3095 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3097 /* Use the actual tree type and not the wrapped coarray. */
3098 if (!se->want_pointer)
3099 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3106 /* Handle scalarized references separately. */
3107 if (ar->type != AR_ELEMENT)
3109 gfc_conv_scalarized_array_ref (se, ar);
3110 gfc_advance_se_ss_chain (se);
3114 cst_offset = offset = gfc_index_zero_node;
3115 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3117 /* Calculate the offsets from all the dimensions. Make sure to associate
3118 the final offset so that we form a chain of loop invariant summands. */
3119 for (n = ar->dimen - 1; n >= 0; n--)
3121 /* Calculate the index for this dimension. */
3122 gfc_init_se (&indexse, se);
3123 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3124 gfc_add_block_to_block (&se->pre, &indexse.pre);
3126 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3128 /* Check array bounds. */
3132 /* Evaluate the indexse.expr only once. */
3133 indexse.expr = save_expr (indexse.expr);
3136 tmp = gfc_conv_array_lbound (se->expr, n);
3137 if (sym->attr.temporary)
3139 gfc_init_se (&tmpse, se);
3140 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3141 gfc_array_index_type);
3142 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3146 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3148 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3149 "below lower bound of %%ld", n+1, sym->name);
3150 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3151 fold_convert (long_integer_type_node,
3153 fold_convert (long_integer_type_node, tmp));
3156 /* Upper bound, but not for the last dimension of assumed-size
3158 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3160 tmp = gfc_conv_array_ubound (se->expr, n);
3161 if (sym->attr.temporary)
3163 gfc_init_se (&tmpse, se);
3164 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3165 gfc_array_index_type);
3166 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3170 cond = fold_build2_loc (input_location, GT_EXPR,
3171 boolean_type_node, indexse.expr, tmp);
3172 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3173 "above upper bound of %%ld", n+1, sym->name);
3174 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3175 fold_convert (long_integer_type_node,
3177 fold_convert (long_integer_type_node, tmp));
3182 /* Multiply the index by the stride. */
3183 stride = gfc_conv_array_stride (se->expr, n);
3184 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3185 indexse.expr, stride);
3187 /* And add it to the total. */
3188 add_to_offset (&cst_offset, &offset, tmp);
3191 if (!integer_zerop (cst_offset))
3192 offset = fold_build2_loc (input_location, PLUS_EXPR,
3193 gfc_array_index_type, offset, cst_offset);
3195 /* Access the calculated element. */
3196 tmp = gfc_conv_array_data (se->expr);
3197 tmp = build_fold_indirect_ref (tmp);
3198 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
3202 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3203 LOOP_DIM dimension (if any) to array's offset. */
3206 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3207 gfc_array_ref *ar, int array_dim, int loop_dim)
3210 gfc_array_info *info;
3213 info = &ss->info->data.array;
3215 gfc_init_se (&se, NULL);
3217 se.expr = info->descriptor;
3218 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3219 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3220 gfc_add_block_to_block (pblock, &se.pre);
3222 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3223 gfc_array_index_type,
3224 info->offset, index);
3225 info->offset = gfc_evaluate_now (info->offset, pblock);
3229 /* Generate the code to be executed immediately before entering a
3230 scalarization loop. */
3233 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3234 stmtblock_t * pblock)
3237 gfc_ss_info *ss_info;
3238 gfc_array_info *info;
3239 gfc_ss_type ss_type;
3241 gfc_loopinfo *ploop;
3245 /* This code will be executed before entering the scalarization loop
3246 for this dimension. */
3247 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3251 if ((ss_info->useflags & flag) == 0)
3254 ss_type = ss_info->type;
3255 if (ss_type != GFC_SS_SECTION
3256 && ss_type != GFC_SS_FUNCTION
3257 && ss_type != GFC_SS_CONSTRUCTOR
3258 && ss_type != GFC_SS_COMPONENT)
3261 info = &ss_info->data.array;
3263 gcc_assert (dim < ss->dimen);
3264 gcc_assert (ss->dimen == loop->dimen);
3267 ar = &info->ref->u.ar;
3271 if (dim == loop->dimen - 1 && loop->parent != NULL)
3273 /* If we are in the outermost dimension of this loop, the previous
3274 dimension shall be in the parent loop. */
3275 gcc_assert (ss->parent != NULL);
3278 ploop = loop->parent;
3280 /* ss and ss->parent are about the same array. */
3281 gcc_assert (ss_info == pss->info);
3289 if (dim == loop->dimen - 1)
3294 /* For the time being, there is no loop reordering. */
3295 gcc_assert (i == ploop->order[i]);
3296 i = ploop->order[i];
3298 if (dim == loop->dimen - 1 && loop->parent == NULL)
3300 stride = gfc_conv_array_stride (info->descriptor,
3301 innermost_ss (ss)->dim[i]);
3303 /* Calculate the stride of the innermost loop. Hopefully this will
3304 allow the backend optimizers to do their stuff more effectively.
3306 info->stride0 = gfc_evaluate_now (stride, pblock);
3308 /* For the outermost loop calculate the offset due to any
3309 elemental dimensions. It will have been initialized with the
3310 base offset of the array. */
3313 for (i = 0; i < ar->dimen; i++)
3315 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3318 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3323 /* Add the offset for the previous loop dimension. */
3324 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3326 /* Remember this offset for the second loop. */
3327 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3328 info->saved_offset = info->offset;
3333 /* Start a scalarized expression. Creates a scope and declares loop
3337 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3343 gcc_assert (!loop->array_parameter);
3345 for (dim = loop->dimen - 1; dim >= 0; dim--)
3347 n = loop->order[dim];
3349 gfc_start_block (&loop->code[n]);
3351 /* Create the loop variable. */
3352 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3354 if (dim < loop->temp_dim)
3358 /* Calculate values that will be constant within this loop. */
3359 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3361 gfc_start_block (pbody);
3365 /* Generates the actual loop code for a scalarization loop. */
3368 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3369 stmtblock_t * pbody)
3380 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3381 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3382 && n == loop->dimen - 1)
3384 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3385 init = make_tree_vec (1);
3386 cond = make_tree_vec (1);
3387 incr = make_tree_vec (1);
3389 /* Cycle statement is implemented with a goto. Exit statement must not
3390 be present for this loop. */
3391 exit_label = gfc_build_label_decl (NULL_TREE);
3392 TREE_USED (exit_label) = 1;
3394 /* Label for cycle statements (if needed). */
3395 tmp = build1_v (LABEL_EXPR, exit_label);
3396 gfc_add_expr_to_block (pbody, tmp);
3398 stmt = make_node (OMP_FOR);
3400 TREE_TYPE (stmt) = void_type_node;
3401 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3403 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3404 OMP_CLAUSE_SCHEDULE);
3405 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3406 = OMP_CLAUSE_SCHEDULE_STATIC;
3407 if (ompws_flags & OMPWS_NOWAIT)
3408 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3409 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3411 /* Initialize the loopvar. */
3412 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3414 OMP_FOR_INIT (stmt) = init;
3415 /* The exit condition. */
3416 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3418 loop->loopvar[n], loop->to[n]);
3419 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3420 OMP_FOR_COND (stmt) = cond;
3421 /* Increment the loopvar. */
3422 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3423 loop->loopvar[n], gfc_index_one_node);
3424 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3425 void_type_node, loop->loopvar[n], tmp);
3426 OMP_FOR_INCR (stmt) = incr;
3428 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3429 gfc_add_expr_to_block (&loop->code[n], stmt);
3433 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3434 && (loop->temp_ss == NULL);
3436 loopbody = gfc_finish_block (pbody);
3440 tmp = loop->from[n];
3441 loop->from[n] = loop->to[n];
3445 /* Initialize the loopvar. */
3446 if (loop->loopvar[n] != loop->from[n])
3447 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3449 exit_label = gfc_build_label_decl (NULL_TREE);
3451 /* Generate the loop body. */
3452 gfc_init_block (&block);
3454 /* The exit condition. */
3455 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3456 boolean_type_node, loop->loopvar[n], loop->to[n]);
3457 tmp = build1_v (GOTO_EXPR, exit_label);
3458 TREE_USED (exit_label) = 1;
3459 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3460 gfc_add_expr_to_block (&block, tmp);
3462 /* The main body. */
3463 gfc_add_expr_to_block (&block, loopbody);
3465 /* Increment the loopvar. */
3466 tmp = fold_build2_loc (input_location,
3467 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3468 gfc_array_index_type, loop->loopvar[n],
3469 gfc_index_one_node);
3471 gfc_add_modify (&block, loop->loopvar[n], tmp);
3473 /* Build the loop. */
3474 tmp = gfc_finish_block (&block);
3475 tmp = build1_v (LOOP_EXPR, tmp);
3476 gfc_add_expr_to_block (&loop->code[n], tmp);
3478 /* Add the exit label. */
3479 tmp = build1_v (LABEL_EXPR, exit_label);
3480 gfc_add_expr_to_block (&loop->code[n], tmp);
3486 /* Finishes and generates the loops for a scalarized expression. */
3489 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3494 stmtblock_t *pblock;
3498 /* Generate the loops. */
3499 for (dim = 0; dim < loop->dimen; dim++)
3501 n = loop->order[dim];
3502 gfc_trans_scalarized_loop_end (loop, n, pblock);
3503 loop->loopvar[n] = NULL_TREE;
3504 pblock = &loop->code[n];
3507 tmp = gfc_finish_block (pblock);
3508 gfc_add_expr_to_block (&loop->pre, tmp);
3510 /* Clear all the used flags. */
3511 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3512 if (ss->parent == NULL)
3513 ss->info->useflags = 0;
3517 /* Finish the main body of a scalarized expression, and start the secondary
3521 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3525 stmtblock_t *pblock;
3529 /* We finish as many loops as are used by the temporary. */
3530 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3532 n = loop->order[dim];
3533 gfc_trans_scalarized_loop_end (loop, n, pblock);
3534 loop->loopvar[n] = NULL_TREE;
3535 pblock = &loop->code[n];
3538 /* We don't want to finish the outermost loop entirely. */
3539 n = loop->order[loop->temp_dim - 1];
3540 gfc_trans_scalarized_loop_end (loop, n, pblock);
3542 /* Restore the initial offsets. */
3543 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3545 gfc_ss_type ss_type;
3546 gfc_ss_info *ss_info;
3550 if ((ss_info->useflags & 2) == 0)
3553 ss_type = ss_info->type;
3554 if (ss_type != GFC_SS_SECTION
3555 && ss_type != GFC_SS_FUNCTION
3556 && ss_type != GFC_SS_CONSTRUCTOR
3557 && ss_type != GFC_SS_COMPONENT)
3560 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3563 /* Restart all the inner loops we just finished. */
3564 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3566 n = loop->order[dim];
3568 gfc_start_block (&loop->code[n]);
3570 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3572 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3575 /* Start a block for the secondary copying code. */
3576 gfc_start_block (body);
3580 /* Precalculate (either lower or upper) bound of an array section.
3581 BLOCK: Block in which the (pre)calculation code will go.
3582 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3583 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3584 DESC: Array descriptor from which the bound will be picked if unspecified
3585 (either lower or upper bound according to LBOUND). */
3588 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3589 tree desc, int dim, bool lbound)
3592 gfc_expr * input_val = values[dim];
3593 tree *output = &bounds[dim];
3598 /* Specified section bound. */
3599 gfc_init_se (&se, NULL);
3600 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3601 gfc_add_block_to_block (block, &se.pre);
3606 /* No specific bound specified so use the bound of the array. */
3607 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3608 gfc_conv_array_ubound (desc, dim);
3610 *output = gfc_evaluate_now (*output, block);
3614 /* Calculate the lower bound of an array section. */
3617 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3619 gfc_expr *stride = NULL;
3622 gfc_array_info *info;
3625 gcc_assert (ss->info->type == GFC_SS_SECTION);
3627 info = &ss->info->data.array;
3628 ar = &info->ref->u.ar;
3630 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3632 /* We use a zero-based index to access the vector. */
3633 info->start[dim] = gfc_index_zero_node;
3634 info->end[dim] = NULL;
3635 info->stride[dim] = gfc_index_one_node;
3639 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3640 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3641 desc = info->descriptor;
3642 stride = ar->stride[dim];
3644 /* Calculate the start of the range. For vector subscripts this will
3645 be the range of the vector. */
3646 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3648 /* Similarly calculate the end. Although this is not used in the
3649 scalarizer, it is needed when checking bounds and where the end
3650 is an expression with side-effects. */
3651 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3653 /* Calculate the stride. */
3655 info->stride[dim] = gfc_index_one_node;
3658 gfc_init_se (&se, NULL);
3659 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3660 gfc_add_block_to_block (&loop->pre, &se.pre);
3661 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3666 /* Calculates the range start and stride for a SS chain. Also gets the
3667 descriptor and data pointer. The range of vector subscripts is the size
3668 of the vector. Array bounds are also checked. */
3671 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3679 /* Determine the rank of the loop. */
3680 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3682 switch (ss->info->type)
3684 case GFC_SS_SECTION:
3685 case GFC_SS_CONSTRUCTOR:
3686 case GFC_SS_FUNCTION:
3687 case GFC_SS_COMPONENT:
3688 loop->dimen = ss->dimen;
3691 /* As usual, lbound and ubound are exceptions!. */
3692 case GFC_SS_INTRINSIC:
3693 switch (ss->info->expr->value.function.isym->id)
3695 case GFC_ISYM_LBOUND:
3696 case GFC_ISYM_UBOUND:
3697 case GFC_ISYM_LCOBOUND:
3698 case GFC_ISYM_UCOBOUND:
3699 case GFC_ISYM_THIS_IMAGE:
3700 loop->dimen = ss->dimen;
3712 /* We should have determined the rank of the expression by now. If
3713 not, that's bad news. */
3717 /* Loop over all the SS in the chain. */
3718 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3720 gfc_ss_info *ss_info;
3721 gfc_array_info *info;
3725 expr = ss_info->expr;
3726 info = &ss_info->data.array;
3728 if (expr && expr->shape && !info->shape)
3729 info->shape = expr->shape;
3731 switch (ss_info->type)
3733 case GFC_SS_SECTION:
3734 /* Get the descriptor for the array. If it is a cross loops array,
3735 we got the descriptor already in the outermost loop. */
3736 if (ss->parent == NULL)
3737 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3739 for (n = 0; n < ss->dimen; n++)
3740 gfc_conv_section_startstride (loop, ss, ss->dim[n]);
3743 case GFC_SS_INTRINSIC:
3744 switch (expr->value.function.isym->id)
3746 /* Fall through to supply start and stride. */
3747 case GFC_ISYM_LBOUND:
3748 case GFC_ISYM_UBOUND:
3749 case GFC_ISYM_LCOBOUND:
3750 case GFC_ISYM_UCOBOUND:
3751 case GFC_ISYM_THIS_IMAGE:
3758 case GFC_SS_CONSTRUCTOR:
3759 case GFC_SS_FUNCTION:
3760 for (n = 0; n < ss->dimen; n++)
3762 int dim = ss->dim[n];
3764 info->start[dim] = gfc_index_zero_node;
3765 info->end[dim] = gfc_index_zero_node;
3766 info->stride[dim] = gfc_index_one_node;
3775 /* The rest is just runtime bound checking. */
3776 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3779 tree lbound, ubound;
3781 tree size[GFC_MAX_DIMENSIONS];
3782 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3783 gfc_array_info *info;
3787 gfc_start_block (&block);
3789 for (n = 0; n < loop->dimen; n++)
3790 size[n] = NULL_TREE;
3792 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3795 gfc_ss_info *ss_info;
3798 const char *expr_name;
3801 if (ss_info->type != GFC_SS_SECTION)
3804 /* Catch allocatable lhs in f2003. */
3805 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3808 expr = ss_info->expr;
3809 expr_loc = &expr->where;
3810 expr_name = expr->symtree->name;
3812 gfc_start_block (&inner);
3814 /* TODO: range checking for mapped dimensions. */
3815 info = &ss_info->data.array;
3817 /* This code only checks ranges. Elemental and vector
3818 dimensions are checked later. */
3819 for (n = 0; n < loop->dimen; n++)
3824 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3827 if (dim == info->ref->u.ar.dimen - 1
3828 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3829 check_upper = false;
3833 /* Zero stride is not allowed. */
3834 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3835 info->stride[dim], gfc_index_zero_node);
3836 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3837 "of array '%s'", dim + 1, expr_name);
3838 gfc_trans_runtime_check (true, false, tmp, &inner,
3842 desc = info->descriptor;
3844 /* This is the run-time equivalent of resolve.c's
3845 check_dimension(). The logical is more readable there
3846 than it is here, with all the trees. */
3847 lbound = gfc_conv_array_lbound (desc, dim);
3848 end = info->end[dim];
3850 ubound = gfc_conv_array_ubound (desc, dim);
3854 /* non_zerosized is true when the selected range is not
3856 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3857 boolean_type_node, info->stride[dim],
3858 gfc_index_zero_node);
3859 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3860 info->start[dim], end);
3861 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3862 boolean_type_node, stride_pos, tmp);
3864 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3866 info->stride[dim], gfc_index_zero_node);
3867 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3868 info->start[dim], end);
3869 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3872 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3874 stride_pos, stride_neg);
3876 /* Check the start of the range against the lower and upper
3877 bounds of the array, if the range is not empty.
3878 If upper bound is present, include both bounds in the
3882 tmp = fold_build2_loc (input_location, LT_EXPR,
3884 info->start[dim], lbound);
3885 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3887 non_zerosized, tmp);
3888 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3890 info->start[dim], ubound);
3891 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3893 non_zerosized, tmp2);
3894 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3895 "outside of expected range (%%ld:%%ld)",
3896 dim + 1, expr_name);
3897 gfc_trans_runtime_check (true, false, tmp, &inner,
3899 fold_convert (long_integer_type_node, info->start[dim]),
3900 fold_convert (long_integer_type_node, lbound),
3901 fold_convert (long_integer_type_node, ubound));
3902 gfc_trans_runtime_check (true, false, tmp2, &inner,
3904 fold_convert (long_integer_type_node, info->start[dim]),
3905 fold_convert (long_integer_type_node, lbound),
3906 fold_convert (long_integer_type_node, ubound));
3911 tmp = fold_build2_loc (input_location, LT_EXPR,
3913 info->start[dim], lbound);
3914 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3915 boolean_type_node, non_zerosized, tmp);
3916 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3917 "below lower bound of %%ld",
3918 dim + 1, expr_name);
3919 gfc_trans_runtime_check (true, false, tmp, &inner,
3921 fold_convert (long_integer_type_node, info->start[dim]),
3922 fold_convert (long_integer_type_node, lbound));
3926 /* Compute the last element of the range, which is not
3927 necessarily "end" (think 0:5:3, which doesn't contain 5)
3928 and check it against both lower and upper bounds. */
3930 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3931 gfc_array_index_type, end,
3933 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3934 gfc_array_index_type, tmp,
3936 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3937 gfc_array_index_type, end, tmp);
3938 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3939 boolean_type_node, tmp, lbound);
3940 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3941 boolean_type_node, non_zerosized, tmp2);
3944 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3945 boolean_type_node, tmp, ubound);
3946 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3947 boolean_type_node, non_zerosized, tmp3);
3948 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3949 "outside of expected range (%%ld:%%ld)",
3950 dim + 1, expr_name);
3951 gfc_trans_runtime_check (true, false, tmp2, &inner,
3953 fold_convert (long_integer_type_node, tmp),
3954 fold_convert (long_integer_type_node, ubound),
3955 fold_convert (long_integer_type_node, lbound));
3956 gfc_trans_runtime_check (true, false, tmp3, &inner,
3958 fold_convert (long_integer_type_node, tmp),
3959 fold_convert (long_integer_type_node, ubound),
3960 fold_convert (long_integer_type_node, lbound));
3965 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3966 "below lower bound of %%ld",
3967 dim + 1, expr_name);
3968 gfc_trans_runtime_check (true, false, tmp2, &inner,
3970 fold_convert (long_integer_type_node, tmp),
3971 fold_convert (long_integer_type_node, lbound));
3975 /* Check the section sizes match. */
3976 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3977 gfc_array_index_type, end,
3979 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3980 gfc_array_index_type, tmp,
3982 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3983 gfc_array_index_type,
3984 gfc_index_one_node, tmp);
3985 tmp = fold_build2_loc (input_location, MAX_EXPR,
3986 gfc_array_index_type, tmp,
3987 build_int_cst (gfc_array_index_type, 0));
3988 /* We remember the size of the first section, and check all the
3989 others against this. */
3992 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3993 boolean_type_node, tmp, size[n]);
3994 asprintf (&msg, "Array bound mismatch for dimension %d "
3995 "of array '%s' (%%ld/%%ld)",
3996 dim + 1, expr_name);
3998 gfc_trans_runtime_check (true, false, tmp3, &inner,
4000 fold_convert (long_integer_type_node, tmp),
4001 fold_convert (long_integer_type_node, size[n]));
4006 size[n] = gfc_evaluate_now (tmp, &inner);
4009 tmp = gfc_finish_block (&inner);
4011 /* For optional arguments, only check bounds if the argument is
4013 if (expr->symtree->n.sym->attr.optional
4014 || expr->symtree->n.sym->attr.not_always_present)
4015 tmp = build3_v (COND_EXPR,
4016 gfc_conv_expr_present (expr->symtree->n.sym),
4017 tmp, build_empty_stmt (input_location));
4019 gfc_add_expr_to_block (&block, tmp);
4023 tmp = gfc_finish_block (&block);
4024 gfc_add_expr_to_block (&loop->pre, tmp);
4027 for (loop = loop->nested; loop; loop = loop->next)
4028 gfc_conv_ss_startstride (loop);
4031 /* Return true if both symbols could refer to the same data object. Does
4032 not take account of aliasing due to equivalence statements. */
4035 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4036 bool lsym_target, bool rsym_pointer, bool rsym_target)
4038 /* Aliasing isn't possible if the symbols have different base types. */
4039 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4042 /* Pointers can point to other pointers and target objects. */
4044 if ((lsym_pointer && (rsym_pointer || rsym_target))
4045 || (rsym_pointer && (lsym_pointer || lsym_target)))
4048 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4049 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4051 if (lsym_target && rsym_target
4052 && ((lsym->attr.dummy && !lsym->attr.contiguous
4053 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4054 || (rsym->attr.dummy && !rsym->attr.contiguous
4055 && (!rsym->attr.dimension
4056 || rsym->as->type == AS_ASSUMED_SHAPE))))
4063 /* Return true if the two SS could be aliased, i.e. both point to the same data
4065 /* TODO: resolve aliases based on frontend expressions. */
4068 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4072 gfc_expr *lexpr, *rexpr;
4075 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4077 lexpr = lss->info->expr;
4078 rexpr = rss->info->expr;
4080 lsym = lexpr->symtree->n.sym;
4081 rsym = rexpr->symtree->n.sym;
4083 lsym_pointer = lsym->attr.pointer;
4084 lsym_target = lsym->attr.target;
4085 rsym_pointer = rsym->attr.pointer;
4086 rsym_target = rsym->attr.target;
4088 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4089 rsym_pointer, rsym_target))
4092 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4093 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4096 /* For derived types we must check all the component types. We can ignore
4097 array references as these will have the same base type as the previous
4099 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4101 if (lref->type != REF_COMPONENT)
4104 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4105 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4107 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4108 rsym_pointer, rsym_target))
4111 if ((lsym_pointer && (rsym_pointer || rsym_target))
4112 || (rsym_pointer && (lsym_pointer || lsym_target)))
4114 if (gfc_compare_types (&lref->u.c.component->ts,
4119 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4122 if (rref->type != REF_COMPONENT)
4125 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4126 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4128 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4129 lsym_pointer, lsym_target,
4130 rsym_pointer, rsym_target))
4133 if ((lsym_pointer && (rsym_pointer || rsym_target))
4134 || (rsym_pointer && (lsym_pointer || lsym_target)))
4136 if (gfc_compare_types (&lref->u.c.component->ts,
4137 &rref->u.c.sym->ts))
4139 if (gfc_compare_types (&lref->u.c.sym->ts,
4140 &rref->u.c.component->ts))
4142 if (gfc_compare_types (&lref->u.c.component->ts,
4143 &rref->u.c.component->ts))
4149 lsym_pointer = lsym->attr.pointer;
4150 lsym_target = lsym->attr.target;
4151 lsym_pointer = lsym->attr.pointer;
4152 lsym_target = lsym->attr.target;
4154 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4156 if (rref->type != REF_COMPONENT)
4159 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4160 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4162 if (symbols_could_alias (rref->u.c.sym, lsym,
4163 lsym_pointer, lsym_target,
4164 rsym_pointer, rsym_target))
4167 if ((lsym_pointer && (rsym_pointer || rsym_target))
4168 || (rsym_pointer && (lsym_pointer || lsym_target)))
4170 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4179 /* Resolve array data dependencies. Creates a temporary if required. */
4180 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4184 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4190 gfc_expr *dest_expr;
4195 loop->temp_ss = NULL;
4196 dest_expr = dest->info->expr;
4198 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4200 if (ss->info->type != GFC_SS_SECTION)
4203 ss_expr = ss->info->expr;
4205 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4207 if (gfc_could_be_alias (dest, ss)
4208 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4216 lref = dest_expr->ref;
4217 rref = ss_expr->ref;
4219 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4224 for (i = 0; i < dest->dimen; i++)
4225 for (j = 0; j < ss->dimen; j++)
4227 && dest->dim[i] == ss->dim[j])
4229 /* If we don't access array elements in the same order,
4230 there is a dependency. */
4235 /* TODO : loop shifting. */
4238 /* Mark the dimensions for LOOP SHIFTING */
4239 for (n = 0; n < loop->dimen; n++)
4241 int dim = dest->data.info.dim[n];
4243 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4245 else if (! gfc_is_same_range (&lref->u.ar,
4246 &rref->u.ar, dim, 0))
4250 /* Put all the dimensions with dependencies in the
4253 for (n = 0; n < loop->dimen; n++)
4255 gcc_assert (loop->order[n] == n);
4257 loop->order[dim++] = n;
4259 for (n = 0; n < loop->dimen; n++)
4262 loop->order[dim++] = n;
4265 gcc_assert (dim == loop->dimen);
4276 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4277 if (GFC_ARRAY_TYPE_P (base_type)
4278 || GFC_DESCRIPTOR_TYPE_P (base_type))
4279 base_type = gfc_get_element_type (base_type);
4280 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4282 gfc_add_ss_to_loop (loop, loop->temp_ss);
4285 loop->temp_ss = NULL;
4289 /* Browse through each array's information from the scalarizer and set the loop
4290 bounds according to the "best" one (per dimension), i.e. the one which
4291 provides the most information (constant bounds, shape, etc). */
4294 set_loop_bounds (gfc_loopinfo *loop)
4296 int n, dim, spec_dim;
4297 gfc_array_info *info;
4298 gfc_array_info *specinfo;
4302 bool dynamic[GFC_MAX_DIMENSIONS];
4306 loopspec = loop->specloop;
4309 for (n = 0; n < loop->dimen; n++)
4313 /* We use one SS term, and use that to determine the bounds of the
4314 loop for this dimension. We try to pick the simplest term. */
4315 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4317 gfc_ss_type ss_type;
4319 ss_type = ss->info->type;
4320 if (ss_type == GFC_SS_SCALAR
4321 || ss_type == GFC_SS_TEMP
4322 || ss_type == GFC_SS_REFERENCE)
4325 info = &ss->info->data.array;
4328 if (loopspec[n] != NULL)
4330 specinfo = &loopspec[n]->info->data.array;
4331 spec_dim = loopspec[n]->dim[n];
4335 /* Silence unitialized warnings. */
4342 gcc_assert (info->shape[dim]);
4343 /* The frontend has worked out the size for us. */
4346 || !integer_zerop (specinfo->start[spec_dim]))
4347 /* Prefer zero-based descriptors if possible. */
4352 if (ss_type == GFC_SS_CONSTRUCTOR)
4354 gfc_constructor_base base;
4355 /* An unknown size constructor will always be rank one.
4356 Higher rank constructors will either have known shape,
4357 or still be wrapped in a call to reshape. */
4358 gcc_assert (loop->dimen == 1);
4360 /* Always prefer to use the constructor bounds if the size
4361 can be determined at compile time. Prefer not to otherwise,
4362 since the general case involves realloc, and it's better to
4363 avoid that overhead if possible. */
4364 base = ss->info->expr->value.constructor;
4365 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4366 if (!dynamic[n] || !loopspec[n])
4371 /* TODO: Pick the best bound if we have a choice between a
4372 function and something else. */
4373 if (ss_type == GFC_SS_FUNCTION)
4379 /* Avoid using an allocatable lhs in an assignment, since
4380 there might be a reallocation coming. */
4381 if (loopspec[n] && ss->is_alloc_lhs)
4384 if (ss_type != GFC_SS_SECTION)
4389 /* Criteria for choosing a loop specifier (most important first):
4390 doesn't need realloc
4396 else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4397 || n >= loop->dimen)
4399 else if (integer_onep (info->stride[dim])
4400 && !integer_onep (specinfo->stride[spec_dim]))
4402 else if (INTEGER_CST_P (info->stride[dim])
4403 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4405 else if (INTEGER_CST_P (info->start[dim])
4406 && !INTEGER_CST_P (specinfo->start[spec_dim]))
4408 /* We don't work out the upper bound.
4409 else if (INTEGER_CST_P (info->finish[n])
4410 && ! INTEGER_CST_P (specinfo->finish[n]))
4411 loopspec[n] = ss; */
4414 /* We should have found the scalarization loop specifier. If not,
4416 gcc_assert (loopspec[n]);
4418 info = &loopspec[n]->info->data.array;
4419 dim = loopspec[n]->dim[n];
4421 /* Set the extents of this range. */
4422 cshape = info->shape;
4423 if (cshape && INTEGER_CST_P (info->start[dim])
4424 && INTEGER_CST_P (info->stride[dim]))
4426 loop->from[n] = info->start[dim];
4427 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
4428 mpz_sub_ui (i, i, 1);
4429 /* To = from + (size - 1) * stride. */
4430 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4431 if (!integer_onep (info->stride[dim]))
4432 tmp = fold_build2_loc (input_location, MULT_EXPR,
4433 gfc_array_index_type, tmp,
4435 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4436 gfc_array_index_type,
4437 loop->from[n], tmp);
4441 loop->from[n] = info->start[dim];
4442 switch (loopspec[n]->info->type)
4444 case GFC_SS_CONSTRUCTOR:
4445 /* The upper bound is calculated when we expand the
4447 gcc_assert (loop->to[n] == NULL_TREE);
4450 case GFC_SS_SECTION:
4451 /* Use the end expression if it exists and is not constant,
4452 so that it is only evaluated once. */
4453 loop->to[n] = info->end[dim];
4456 case GFC_SS_FUNCTION:
4457 /* The loop bound will be set when we generate the call. */
4458 gcc_assert (loop->to[n] == NULL_TREE);
4466 /* Transform everything so we have a simple incrementing variable. */
4467 if (integer_onep (info->stride[dim]))
4468 info->delta[dim] = gfc_index_zero_node;
4471 /* Set the delta for this section. */
4472 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4473 /* Number of iterations is (end - start + step) / step.
4474 with start = 0, this simplifies to
4476 for (i = 0; i<=last; i++){...}; */
4477 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4478 gfc_array_index_type, loop->to[n],
4480 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4481 gfc_array_index_type, tmp, info->stride[dim]);
4482 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4483 tmp, build_int_cst (gfc_array_index_type, -1));
4484 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4485 /* Make the loop variable start at 0. */
4486 loop->from[n] = gfc_index_zero_node;
4491 for (loop = loop->nested; loop; loop = loop->next)
4492 set_loop_bounds (loop);
4496 /* Initialize the scalarization loop. Creates the loop variables. Determines
4497 the range of the loop variables. Creates a temporary if required.
4498 Also generates code for scalar expressions which have been
4499 moved outside the loop. */
4502 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4507 set_loop_bounds (loop);
4509 /* Add all the scalar code that can be taken out of the loops.
4510 This may include calculating the loop bounds, so do it before
4511 allocating the temporary. */
4512 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4514 tmp_ss = loop->temp_ss;
4515 /* If we want a temporary then create it. */
4518 gfc_ss_info *tmp_ss_info;
4520 tmp_ss_info = tmp_ss->info;
4521 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4522 gcc_assert (loop->parent == NULL);
4524 /* Make absolutely sure that this is a complete type. */
4525 if (tmp_ss_info->string_length)
4526 tmp_ss_info->data.temp.type
4527 = gfc_get_character_type_len_for_eltype
4528 (TREE_TYPE (tmp_ss_info->data.temp.type),
4529 tmp_ss_info->string_length);
4531 tmp = tmp_ss_info->data.temp.type;
4532 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4533 tmp_ss_info->type = GFC_SS_SECTION;
4535 gcc_assert (tmp_ss->dimen != 0);
4537 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4538 NULL_TREE, false, true, false, where);
4541 /* For array parameters we don't have loop variables, so don't calculate the
4543 if (!loop->array_parameter)
4544 gfc_set_delta (loop);
4548 /* Calculates how to transform from loop variables to array indices for each
4549 array: once loop bounds are chosen, sets the difference (DELTA field) between
4550 loop bounds and array reference bounds, for each array info. */
4553 gfc_set_delta (gfc_loopinfo *loop)
4555 gfc_ss *ss, **loopspec;
4556 gfc_array_info *info;
4560 loopspec = loop->specloop;
4562 /* Calculate the translation from loop variables to array indices. */
4563 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4565 gfc_ss_type ss_type;
4567 ss_type = ss->info->type;
4568 if (ss_type != GFC_SS_SECTION
4569 && ss_type != GFC_SS_COMPONENT
4570 && ss_type != GFC_SS_CONSTRUCTOR)
4573 info = &ss->info->data.array;
4575 for (n = 0; n < ss->dimen; n++)
4577 /* If we are specifying the range the delta is already set. */
4578 if (loopspec[n] != ss)
4582 /* Calculate the offset relative to the loop variable.
4583 First multiply by the stride. */
4584 tmp = loop->from[n];
4585 if (!integer_onep (info->stride[dim]))
4586 tmp = fold_build2_loc (input_location, MULT_EXPR,
4587 gfc_array_index_type,
4588 tmp, info->stride[dim]);
4590 /* Then subtract this from our starting value. */
4591 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4592 gfc_array_index_type,
4593 info->start[dim], tmp);
4595 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4600 for (loop = loop->nested; loop; loop = loop->next)
4601 gfc_set_delta (loop);
4605 /* Calculate the size of a given array dimension from the bounds. This
4606 is simply (ubound - lbound + 1) if this expression is positive
4607 or 0 if it is negative (pick either one if it is zero). Optionally
4608 (if or_expr is present) OR the (expression != 0) condition to it. */
4611 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4616 /* Calculate (ubound - lbound + 1). */
4617 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4619 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4620 gfc_index_one_node);
4622 /* Check whether the size for this dimension is negative. */
4623 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4624 gfc_index_zero_node);
4625 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4626 gfc_index_zero_node, res);
4628 /* Build OR expression. */
4630 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4631 boolean_type_node, *or_expr, cond);
4637 /* For an array descriptor, get the total number of elements. This is just
4638 the product of the extents along from_dim to to_dim. */
4641 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4646 res = gfc_index_one_node;
4648 for (dim = from_dim; dim < to_dim; ++dim)
4654 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4655 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4657 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4658 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4666 /* Full size of an array. */
4669 gfc_conv_descriptor_size (tree desc, int rank)
4671 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4675 /* Size of a coarray for all dimensions but the last. */
4678 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4680 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4684 /* Fills in an array descriptor, and returns the size of the array.
4685 The size will be a simple_val, ie a variable or a constant. Also
4686 calculates the offset of the base. The pointer argument overflow,
4687 which should be of integer type, will increase in value if overflow
4688 occurs during the size calculation. Returns the size of the array.
4692 for (n = 0; n < rank; n++)
4694 a.lbound[n] = specified_lower_bound;
4695 offset = offset + a.lbond[n] * stride;
4697 a.ubound[n] = specified_upper_bound;
4698 a.stride[n] = stride;
4699 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4700 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4701 stride = stride * size;
4703 for (n = rank; n < rank+corank; n++)
4704 (Set lcobound/ucobound as above.)
4705 element_size = sizeof (array element);
4708 stride = (size_t) stride;
4709 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4710 stride = stride * element_size;
4716 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4717 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4718 stmtblock_t * descriptor_block, tree * overflow,
4719 tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
4732 stmtblock_t thenblock;
4733 stmtblock_t elseblock;
4738 type = TREE_TYPE (descriptor);
4740 stride = gfc_index_one_node;
4741 offset = gfc_index_zero_node;
4743 /* Set the dtype. */
4744 tmp = gfc_conv_descriptor_dtype (descriptor);
4745 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4747 or_expr = boolean_false_node;
4749 for (n = 0; n < rank; n++)
4754 /* We have 3 possibilities for determining the size of the array:
4755 lower == NULL => lbound = 1, ubound = upper[n]
4756 upper[n] = NULL => lbound = 1, ubound = lower[n]
4757 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4760 /* Set lower bound. */
4761 gfc_init_se (&se, NULL);
4763 se.expr = gfc_index_one_node;
4766 gcc_assert (lower[n]);
4769 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4770 gfc_add_block_to_block (pblock, &se.pre);
4774 se.expr = gfc_index_one_node;
4778 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4779 gfc_rank_cst[n], se.expr);
4780 conv_lbound = se.expr;
4782 /* Work out the offset for this component. */
4783 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4785 offset = fold_build2_loc (input_location, MINUS_EXPR,
4786 gfc_array_index_type, offset, tmp);
4788 /* Set upper bound. */
4789 gfc_init_se (&se, NULL);
4790 gcc_assert (ubound);
4791 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4792 gfc_add_block_to_block (pblock, &se.pre);
4794 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4795 gfc_rank_cst[n], se.expr);
4796 conv_ubound = se.expr;
4798 /* Store the stride. */
4799 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4800 gfc_rank_cst[n], stride);
4802 /* Calculate size and check whether extent is negative. */
4803 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4804 size = gfc_evaluate_now (size, pblock);
4806 /* Check whether multiplying the stride by the number of
4807 elements in this dimension would overflow. We must also check
4808 whether the current dimension has zero size in order to avoid
4811 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4812 gfc_array_index_type,
4813 fold_convert (gfc_array_index_type,
4814 TYPE_MAX_VALUE (gfc_array_index_type)),
4816 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4817 boolean_type_node, tmp, stride));
4818 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4819 integer_one_node, integer_zero_node);
4820 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4821 boolean_type_node, size,
4822 gfc_index_zero_node));
4823 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4824 integer_zero_node, tmp);
4825 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4827 *overflow = gfc_evaluate_now (tmp, pblock);
4829 /* Multiply the stride by the number of elements in this dimension. */
4830 stride = fold_build2_loc (input_location, MULT_EXPR,
4831 gfc_array_index_type, stride, size);
4832 stride = gfc_evaluate_now (stride, pblock);
4835 for (n = rank; n < rank + corank; n++)
4839 /* Set lower bound. */
4840 gfc_init_se (&se, NULL);
4841 if (lower == NULL || lower[n] == NULL)
4843 gcc_assert (n == rank + corank - 1);
4844 se.expr = gfc_index_one_node;
4848 if (ubound || n == rank + corank - 1)
4850 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4851 gfc_add_block_to_block (pblock, &se.pre);
4855 se.expr = gfc_index_one_node;
4859 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4860 gfc_rank_cst[n], se.expr);
4862 if (n < rank + corank - 1)
4864 gfc_init_se (&se, NULL);
4865 gcc_assert (ubound);
4866 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4867 gfc_add_block_to_block (pblock, &se.pre);
4868 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4869 gfc_rank_cst[n], se.expr);
4873 /* The stride is the number of elements in the array, so multiply by the
4874 size of an element to get the total size. Obviously, if there ia a
4875 SOURCE expression (expr3) we must use its element size. */
4876 if (expr3_elem_size != NULL_TREE)
4877 tmp = expr3_elem_size;
4878 else if (expr3 != NULL)
4880 if (expr3->ts.type == BT_CLASS)
4883 gfc_expr *sz = gfc_copy_expr (expr3);
4884 gfc_add_vptr_component (sz);
4885 gfc_add_size_component (sz);
4886 gfc_init_se (&se_sz, NULL);
4887 gfc_conv_expr (&se_sz, sz);
4893 tmp = gfc_typenode_for_spec (&expr3->ts);
4894 tmp = TYPE_SIZE_UNIT (tmp);
4898 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4900 /* Convert to size_t. */
4901 element_size = fold_convert (size_type_node, tmp);
4904 return element_size;
4906 *nelems = gfc_evaluate_now (stride, pblock);
4907 stride = fold_convert (size_type_node, stride);
4909 /* First check for overflow. Since an array of type character can
4910 have zero element_size, we must check for that before
4912 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4914 TYPE_MAX_VALUE (size_type_node), element_size);
4915 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4916 boolean_type_node, tmp, stride));
4917 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4918 integer_one_node, integer_zero_node);
4919 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4920 boolean_type_node, element_size,
4921 build_int_cst (size_type_node, 0)));
4922 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4923 integer_zero_node, tmp);
4924 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4926 *overflow = gfc_evaluate_now (tmp, pblock);
4928 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4929 stride, element_size);
4931 if (poffset != NULL)
4933 offset = gfc_evaluate_now (offset, pblock);
4937 if (integer_zerop (or_expr))
4939 if (integer_onep (or_expr))
4940 return build_int_cst (size_type_node, 0);
4942 var = gfc_create_var (TREE_TYPE (size), "size");
4943 gfc_start_block (&thenblock);
4944 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4945 thencase = gfc_finish_block (&thenblock);
4947 gfc_start_block (&elseblock);
4948 gfc_add_modify (&elseblock, var, size);
4949 elsecase = gfc_finish_block (&elseblock);
4951 tmp = gfc_evaluate_now (or_expr, pblock);
4952 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4953 gfc_add_expr_to_block (pblock, tmp);
4959 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4960 the work for an ALLOCATE statement. */
4964 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4965 tree errlen, tree label_finish, tree expr3_elem_size,
4966 tree *nelems, gfc_expr *expr3)
4970 tree offset = NULL_TREE;
4971 tree token = NULL_TREE;
4974 tree error = NULL_TREE;
4975 tree overflow; /* Boolean storing whether size calculation overflows. */
4976 tree var_overflow = NULL_TREE;
4978 tree set_descriptor;
4979 stmtblock_t set_descriptor_block;
4980 stmtblock_t elseblock;
4983 gfc_ref *ref, *prev_ref = NULL;
4984 bool allocatable, coarray, dimension;
4988 /* Find the last reference in the chain. */
4989 while (ref && ref->next != NULL)
4991 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4992 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4997 if (ref == NULL || ref->type != REF_ARRAY)
5002 allocatable = expr->symtree->n.sym->attr.allocatable;
5003 coarray = expr->symtree->n.sym->attr.codimension;
5004 dimension = expr->symtree->n.sym->attr.dimension;
5008 allocatable = prev_ref->u.c.component->attr.allocatable;
5009 coarray = prev_ref->u.c.component->attr.codimension;
5010 dimension = prev_ref->u.c.component->attr.dimension;
5014 gcc_assert (coarray);
5016 /* Figure out the size of the array. */
5017 switch (ref->u.ar.type)
5023 upper = ref->u.ar.start;
5029 lower = ref->u.ar.start;
5030 upper = ref->u.ar.end;
5034 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
5036 lower = ref->u.ar.as->lower;
5037 upper = ref->u.ar.as->upper;
5045 overflow = integer_zero_node;
5047 gfc_init_block (&set_descriptor_block);
5048 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
5049 ref->u.ar.as->corank, &offset, lower, upper,
5050 &se->pre, &set_descriptor_block, &overflow,
5051 expr3_elem_size, nelems, expr3);
5056 var_overflow = gfc_create_var (integer_type_node, "overflow");
5057 gfc_add_modify (&se->pre, var_overflow, overflow);
5059 /* Generate the block of code handling overflow. */
5060 msg = gfc_build_addr_expr (pchar_type_node,
5061 gfc_build_localized_cstring_const
5062 ("Integer overflow when calculating the amount of "
5063 "memory to allocate"));
5064 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
5068 if (status != NULL_TREE)
5070 tree status_type = TREE_TYPE (status);
5071 stmtblock_t set_status_block;
5073 gfc_start_block (&set_status_block);
5074 gfc_add_modify (&set_status_block, status,
5075 build_int_cst (status_type, LIBERROR_ALLOCATION));
5076 error = gfc_finish_block (&set_status_block);
5079 gfc_start_block (&elseblock);
5081 /* Allocate memory to store the data. */
5082 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5083 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5085 pointer = gfc_conv_descriptor_data_get (se->expr);
5086 STRIP_NOPS (pointer);
5088 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5089 token = gfc_build_addr_expr (NULL_TREE,
5090 gfc_conv_descriptor_token (se->expr));
5092 /* The allocatable variant takes the old pointer as first argument. */
5094 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5095 status, errmsg, errlen, label_finish, expr);
5097 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5101 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5102 boolean_type_node, var_overflow, integer_zero_node));
5103 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5104 error, gfc_finish_block (&elseblock));
5107 tmp = gfc_finish_block (&elseblock);
5109 gfc_add_expr_to_block (&se->pre, tmp);
5111 if (expr->ts.type == BT_CLASS)
5113 tmp = build_int_cst (unsigned_char_type_node, 0);
5114 /* With class objects, it is best to play safe and null the
5115 memory because we cannot know if dynamic types have allocatable
5116 components or not. */
5117 tmp = build_call_expr_loc (input_location,
5118 builtin_decl_explicit (BUILT_IN_MEMSET),
5119 3, pointer, tmp, size);
5120 gfc_add_expr_to_block (&se->pre, tmp);
5123 /* Update the array descriptors. */
5125 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
5127 set_descriptor = gfc_finish_block (&set_descriptor_block);
5128 if (status != NULL_TREE)
5130 cond = fold_build2_loc (input_location, EQ_EXPR,
5131 boolean_type_node, status,
5132 build_int_cst (TREE_TYPE (status), 0));
5133 gfc_add_expr_to_block (&se->pre,
5134 fold_build3_loc (input_location, COND_EXPR, void_type_node,
5135 gfc_likely (cond), set_descriptor,
5136 build_empty_stmt (input_location)));
5139 gfc_add_expr_to_block (&se->pre, set_descriptor);
5141 if ((expr->ts.type == BT_DERIVED)
5142 && expr->ts.u.derived->attr.alloc_comp)
5144 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
5145 ref->u.ar.as->rank);
5146 gfc_add_expr_to_block (&se->pre, tmp);
5153 /* Deallocate an array variable. Also used when an allocated variable goes
5158 gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
5159 tree label_finish, gfc_expr* expr)
5164 bool coarray = gfc_is_coarray (expr);
5166 gfc_start_block (&block);
5168 /* Get a pointer to the data. */
5169 var = gfc_conv_descriptor_data_get (descriptor);
5172 /* Parameter is the address of the data component. */
5173 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
5174 errlen, label_finish, false, expr, coarray);
5175 gfc_add_expr_to_block (&block, tmp);
5177 /* Zero the data pointer; only for coarrays an error can occur and then
5178 the allocation status may not be changed. */
5179 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5180 var, build_int_cst (TREE_TYPE (var), 0));
5181 if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5184 tree stat = build_fold_indirect_ref_loc (input_location, pstat);
5186 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5187 stat, build_int_cst (TREE_TYPE (stat), 0));
5188 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5189 cond, tmp, build_empty_stmt (input_location));
5192 gfc_add_expr_to_block (&block, tmp);
5194 return gfc_finish_block (&block);
5198 /* Create an array constructor from an initialization expression.
5199 We assume the frontend already did any expansions and conversions. */
5202 gfc_conv_array_initializer (tree type, gfc_expr * expr)
5208 unsigned HOST_WIDE_INT lo;
5210 VEC(constructor_elt,gc) *v = NULL;
5212 if (expr->expr_type == EXPR_VARIABLE
5213 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5214 && expr->symtree->n.sym->value)
5215 expr = expr->symtree->n.sym->value;
5217 switch (expr->expr_type)
5220 case EXPR_STRUCTURE:
5221 /* A single scalar or derived type value. Create an array with all
5222 elements equal to that value. */
5223 gfc_init_se (&se, NULL);
5225 if (expr->expr_type == EXPR_CONSTANT)
5226 gfc_conv_constant (&se, expr);
5228 gfc_conv_structure (&se, expr, 1);
5230 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
5231 gcc_assert (tmp && INTEGER_CST_P (tmp));
5232 hi = TREE_INT_CST_HIGH (tmp);
5233 lo = TREE_INT_CST_LOW (tmp);
5237 /* This will probably eat buckets of memory for large arrays. */
5238 while (hi != 0 || lo != 0)
5240 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
5248 /* Create a vector of all the elements. */
5249 for (c = gfc_constructor_first (expr->value.constructor);
5250 c; c = gfc_constructor_next (c))
5254 /* Problems occur when we get something like
5255 integer :: a(lots) = (/(i, i=1, lots)/) */
5256 gfc_fatal_error ("The number of elements in the array constructor "
5257 "at %L requires an increase of the allowed %d "
5258 "upper limit. See -fmax-array-constructor "
5259 "option", &expr->where,
5260 gfc_option.flag_max_array_constructor);
5263 if (mpz_cmp_si (c->offset, 0) != 0)
5264 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5268 if (mpz_cmp_si (c->repeat, 1) > 0)
5274 mpz_add (maxval, c->offset, c->repeat);
5275 mpz_sub_ui (maxval, maxval, 1);
5276 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5277 if (mpz_cmp_si (c->offset, 0) != 0)
5279 mpz_add_ui (maxval, c->offset, 1);
5280 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5283 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5285 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
5291 gfc_init_se (&se, NULL);
5292 switch (c->expr->expr_type)
5295 gfc_conv_constant (&se, c->expr);
5298 case EXPR_STRUCTURE:
5299 gfc_conv_structure (&se, c->expr, 1);
5303 /* Catch those occasional beasts that do not simplify
5304 for one reason or another, assuming that if they are
5305 standard defying the frontend will catch them. */
5306 gfc_conv_expr (&se, c->expr);
5310 if (range == NULL_TREE)
5311 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5314 if (index != NULL_TREE)
5315 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5316 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
5322 return gfc_build_null_descriptor (type);
5328 /* Create a constructor from the list of elements. */
5329 tmp = build_constructor (type, v);
5330 TREE_CONSTANT (tmp) = 1;
5335 /* Generate code to evaluate non-constant coarray cobounds. */
5338 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
5339 const gfc_symbol *sym)
5349 for (dim = as->rank; dim < as->rank + as->corank; dim++)
5351 /* Evaluate non-constant array bound expressions. */
5352 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5353 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5355 gfc_init_se (&se, NULL);
5356 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5357 gfc_add_block_to_block (pblock, &se.pre);
5358 gfc_add_modify (pblock, lbound, se.expr);
5360 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5361 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5363 gfc_init_se (&se, NULL);
5364 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5365 gfc_add_block_to_block (pblock, &se.pre);
5366 gfc_add_modify (pblock, ubound, se.expr);
5372 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5373 returns the size (in elements) of the array. */
5376 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
5377 stmtblock_t * pblock)
5392 size = gfc_index_one_node;
5393 offset = gfc_index_zero_node;
5394 for (dim = 0; dim < as->rank; dim++)
5396 /* Evaluate non-constant array bound expressions. */
5397 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5398 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5400 gfc_init_se (&se, NULL);
5401 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5402 gfc_add_block_to_block (pblock, &se.pre);
5403 gfc_add_modify (pblock, lbound, se.expr);
5405 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5406 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5408 gfc_init_se (&se, NULL);
5409 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5410 gfc_add_block_to_block (pblock, &se.pre);
5411 gfc_add_modify (pblock, ubound, se.expr);
5413 /* The offset of this dimension. offset = offset - lbound * stride. */
5414 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5416 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5419 /* The size of this dimension, and the stride of the next. */
5420 if (dim + 1 < as->rank)
5421 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5423 stride = GFC_TYPE_ARRAY_SIZE (type);
5425 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5427 /* Calculate stride = size * (ubound + 1 - lbound). */
5428 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5429 gfc_array_index_type,
5430 gfc_index_one_node, lbound);
5431 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5432 gfc_array_index_type, ubound, tmp);
5433 tmp = fold_build2_loc (input_location, MULT_EXPR,
5434 gfc_array_index_type, size, tmp);
5436 gfc_add_modify (pblock, stride, tmp);
5438 stride = gfc_evaluate_now (tmp, pblock);
5440 /* Make sure that negative size arrays are translated
5441 to being zero size. */
5442 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5443 stride, gfc_index_zero_node);
5444 tmp = fold_build3_loc (input_location, COND_EXPR,
5445 gfc_array_index_type, tmp,
5446 stride, gfc_index_zero_node);
5447 gfc_add_modify (pblock, stride, tmp);
5453 gfc_trans_array_cobounds (type, pblock, sym);
5454 gfc_trans_vla_type_sizes (sym, pblock);
5461 /* Generate code to initialize/allocate an array variable. */
5464 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5465 gfc_wrapped_block * block)
5469 tree tmp = NULL_TREE;
5476 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5478 /* Do nothing for USEd variables. */
5479 if (sym->attr.use_assoc)
5482 type = TREE_TYPE (decl);
5483 gcc_assert (GFC_ARRAY_TYPE_P (type));
5484 onstack = TREE_CODE (type) != POINTER_TYPE;
5486 gfc_init_block (&init);
5488 /* Evaluate character string length. */
5489 if (sym->ts.type == BT_CHARACTER
5490 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5492 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5494 gfc_trans_vla_type_sizes (sym, &init);
5496 /* Emit a DECL_EXPR for this variable, which will cause the
5497 gimplifier to allocate storage, and all that good stuff. */
5498 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5499 gfc_add_expr_to_block (&init, tmp);
5504 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5508 type = TREE_TYPE (type);
5510 gcc_assert (!sym->attr.use_assoc);
5511 gcc_assert (!TREE_STATIC (decl));
5512 gcc_assert (!sym->module);
5514 if (sym->ts.type == BT_CHARACTER
5515 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5516 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5518 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5520 /* Don't actually allocate space for Cray Pointees. */
5521 if (sym->attr.cray_pointee)
5523 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5524 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5526 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5530 if (gfc_option.flag_stack_arrays)
5532 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5533 space = build_decl (sym->declared_at.lb->location,
5534 VAR_DECL, create_tmp_var_name ("A"),
5535 TREE_TYPE (TREE_TYPE (decl)));
5536 gfc_trans_vla_type_sizes (sym, &init);
5540 /* The size is the number of elements in the array, so multiply by the
5541 size of an element to get the total size. */
5542 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5543 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5544 size, fold_convert (gfc_array_index_type, tmp));
5546 /* Allocate memory to hold the data. */
5547 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5548 gfc_add_modify (&init, decl, tmp);
5550 /* Free the temporary. */
5551 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5555 /* Set offset of the array. */
5556 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5557 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5559 /* Automatic arrays should not have initializers. */
5560 gcc_assert (!sym->value);
5562 inittree = gfc_finish_block (&init);
5569 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5570 where also space is located. */
5571 gfc_init_block (&init);
5572 tmp = fold_build1_loc (input_location, DECL_EXPR,
5573 TREE_TYPE (space), space);
5574 gfc_add_expr_to_block (&init, tmp);
5575 addr = fold_build1_loc (sym->declared_at.lb->location,
5576 ADDR_EXPR, TREE_TYPE (decl), space);
5577 gfc_add_modify (&init, decl, addr);
5578 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5581 gfc_add_init_cleanup (block, inittree, tmp);
5585 /* Generate entry and exit code for g77 calling convention arrays. */
5588 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5598 gfc_save_backend_locus (&loc);
5599 gfc_set_backend_locus (&sym->declared_at);
5601 /* Descriptor type. */
5602 parm = sym->backend_decl;
5603 type = TREE_TYPE (parm);
5604 gcc_assert (GFC_ARRAY_TYPE_P (type));
5606 gfc_start_block (&init);
5608 if (sym->ts.type == BT_CHARACTER
5609 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5610 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5612 /* Evaluate the bounds of the array. */
5613 gfc_trans_array_bounds (type, sym, &offset, &init);
5615 /* Set the offset. */
5616 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5617 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5619 /* Set the pointer itself if we aren't using the parameter directly. */
5620 if (TREE_CODE (parm) != PARM_DECL)
5622 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5623 gfc_add_modify (&init, parm, tmp);
5625 stmt = gfc_finish_block (&init);
5627 gfc_restore_backend_locus (&loc);
5629 /* Add the initialization code to the start of the function. */
5631 if (sym->attr.optional || sym->attr.not_always_present)
5633 tmp = gfc_conv_expr_present (sym);
5634 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5637 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5641 /* Modify the descriptor of an array parameter so that it has the
5642 correct lower bound. Also move the upper bound accordingly.
5643 If the array is not packed, it will be copied into a temporary.
5644 For each dimension we set the new lower and upper bounds. Then we copy the
5645 stride and calculate the offset for this dimension. We also work out
5646 what the stride of a packed array would be, and see it the two match.
5647 If the array need repacking, we set the stride to the values we just
5648 calculated, recalculate the offset and copy the array data.
5649 Code is also added to copy the data back at the end of the function.
5653 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5654 gfc_wrapped_block * block)
5661 tree stmtInit, stmtCleanup;
5668 tree stride, stride2;
5678 /* Do nothing for pointer and allocatable arrays. */
5679 if (sym->attr.pointer || sym->attr.allocatable)
5682 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5684 gfc_trans_g77_array (sym, block);
5688 gfc_save_backend_locus (&loc);
5689 gfc_set_backend_locus (&sym->declared_at);
5691 /* Descriptor type. */
5692 type = TREE_TYPE (tmpdesc);
5693 gcc_assert (GFC_ARRAY_TYPE_P (type));
5694 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5695 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5696 gfc_start_block (&init);
5698 if (sym->ts.type == BT_CHARACTER
5699 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5700 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5702 checkparm = (sym->as->type == AS_EXPLICIT
5703 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5705 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5706 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5708 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5710 /* For non-constant shape arrays we only check if the first dimension
5711 is contiguous. Repacking higher dimensions wouldn't gain us
5712 anything as we still don't know the array stride. */
5713 partial = gfc_create_var (boolean_type_node, "partial");
5714 TREE_USED (partial) = 1;
5715 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5716 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5717 gfc_index_one_node);
5718 gfc_add_modify (&init, partial, tmp);
5721 partial = NULL_TREE;
5723 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5724 here, however I think it does the right thing. */
5727 /* Set the first stride. */
5728 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5729 stride = gfc_evaluate_now (stride, &init);
5731 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5732 stride, gfc_index_zero_node);
5733 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5734 tmp, gfc_index_one_node, stride);
5735 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5736 gfc_add_modify (&init, stride, tmp);
5738 /* Allow the user to disable array repacking. */
5739 stmt_unpacked = NULL_TREE;
5743 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5744 /* A library call to repack the array if necessary. */
5745 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5746 stmt_unpacked = build_call_expr_loc (input_location,
5747 gfor_fndecl_in_pack, 1, tmp);
5749 stride = gfc_index_one_node;
5751 if (gfc_option.warn_array_temp)
5752 gfc_warning ("Creating array temporary at %L", &loc);
5755 /* This is for the case where the array data is used directly without
5756 calling the repack function. */
5757 if (no_repack || partial != NULL_TREE)
5758 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5760 stmt_packed = NULL_TREE;
5762 /* Assign the data pointer. */
5763 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5765 /* Don't repack unknown shape arrays when the first stride is 1. */
5766 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5767 partial, stmt_packed, stmt_unpacked);
5770 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5771 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5773 offset = gfc_index_zero_node;
5774 size = gfc_index_one_node;
5776 /* Evaluate the bounds of the array. */
5777 for (n = 0; n < sym->as->rank; n++)
5779 if (checkparm || !sym->as->upper[n])
5781 /* Get the bounds of the actual parameter. */
5782 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5783 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5787 dubound = NULL_TREE;
5788 dlbound = NULL_TREE;
5791 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5792 if (!INTEGER_CST_P (lbound))
5794 gfc_init_se (&se, NULL);
5795 gfc_conv_expr_type (&se, sym->as->lower[n],
5796 gfc_array_index_type);
5797 gfc_add_block_to_block (&init, &se.pre);
5798 gfc_add_modify (&init, lbound, se.expr);
5801 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5802 /* Set the desired upper bound. */
5803 if (sym->as->upper[n])
5805 /* We know what we want the upper bound to be. */
5806 if (!INTEGER_CST_P (ubound))
5808 gfc_init_se (&se, NULL);
5809 gfc_conv_expr_type (&se, sym->as->upper[n],
5810 gfc_array_index_type);
5811 gfc_add_block_to_block (&init, &se.pre);
5812 gfc_add_modify (&init, ubound, se.expr);
5815 /* Check the sizes match. */
5818 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5822 temp = fold_build2_loc (input_location, MINUS_EXPR,
5823 gfc_array_index_type, ubound, lbound);
5824 temp = fold_build2_loc (input_location, PLUS_EXPR,
5825 gfc_array_index_type,
5826 gfc_index_one_node, temp);
5827 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5828 gfc_array_index_type, dubound,
5830 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5831 gfc_array_index_type,
5832 gfc_index_one_node, stride2);
5833 tmp = fold_build2_loc (input_location, NE_EXPR,
5834 gfc_array_index_type, temp, stride2);
5835 asprintf (&msg, "Dimension %d of array '%s' has extent "
5836 "%%ld instead of %%ld", n+1, sym->name);
5838 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5839 fold_convert (long_integer_type_node, temp),
5840 fold_convert (long_integer_type_node, stride2));
5847 /* For assumed shape arrays move the upper bound by the same amount
5848 as the lower bound. */
5849 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5850 gfc_array_index_type, dubound, dlbound);
5851 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5852 gfc_array_index_type, tmp, lbound);
5853 gfc_add_modify (&init, ubound, tmp);
5855 /* The offset of this dimension. offset = offset - lbound * stride. */
5856 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5858 offset = fold_build2_loc (input_location, MINUS_EXPR,
5859 gfc_array_index_type, offset, tmp);
5861 /* The size of this dimension, and the stride of the next. */
5862 if (n + 1 < sym->as->rank)
5864 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5866 if (no_repack || partial != NULL_TREE)
5868 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5870 /* Figure out the stride if not a known constant. */
5871 if (!INTEGER_CST_P (stride))
5874 stmt_packed = NULL_TREE;
5877 /* Calculate stride = size * (ubound + 1 - lbound). */
5878 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5879 gfc_array_index_type,
5880 gfc_index_one_node, lbound);
5881 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5882 gfc_array_index_type, ubound, tmp);
5883 size = fold_build2_loc (input_location, MULT_EXPR,
5884 gfc_array_index_type, size, tmp);
5888 /* Assign the stride. */
5889 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5890 tmp = fold_build3_loc (input_location, COND_EXPR,
5891 gfc_array_index_type, partial,
5892 stmt_unpacked, stmt_packed);
5894 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5895 gfc_add_modify (&init, stride, tmp);
5900 stride = GFC_TYPE_ARRAY_SIZE (type);
5902 if (stride && !INTEGER_CST_P (stride))
5904 /* Calculate size = stride * (ubound + 1 - lbound). */
5905 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5906 gfc_array_index_type,
5907 gfc_index_one_node, lbound);
5908 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5909 gfc_array_index_type,
5911 tmp = fold_build2_loc (input_location, MULT_EXPR,
5912 gfc_array_index_type,
5913 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5914 gfc_add_modify (&init, stride, tmp);
5919 gfc_trans_array_cobounds (type, &init, sym);
5921 /* Set the offset. */
5922 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5923 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5925 gfc_trans_vla_type_sizes (sym, &init);
5927 stmtInit = gfc_finish_block (&init);
5929 /* Only do the entry/initialization code if the arg is present. */
5930 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5931 optional_arg = (sym->attr.optional
5932 || (sym->ns->proc_name->attr.entry_master
5933 && sym->attr.dummy));
5936 tmp = gfc_conv_expr_present (sym);
5937 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5938 build_empty_stmt (input_location));
5943 stmtCleanup = NULL_TREE;
5946 stmtblock_t cleanup;
5947 gfc_start_block (&cleanup);
5949 if (sym->attr.intent != INTENT_IN)
5951 /* Copy the data back. */
5952 tmp = build_call_expr_loc (input_location,
5953 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5954 gfc_add_expr_to_block (&cleanup, tmp);
5957 /* Free the temporary. */
5958 tmp = gfc_call_free (tmpdesc);
5959 gfc_add_expr_to_block (&cleanup, tmp);
5961 stmtCleanup = gfc_finish_block (&cleanup);
5963 /* Only do the cleanup if the array was repacked. */
5964 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5965 tmp = gfc_conv_descriptor_data_get (tmp);
5966 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5968 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5969 build_empty_stmt (input_location));
5973 tmp = gfc_conv_expr_present (sym);
5974 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5975 build_empty_stmt (input_location));
5979 /* We don't need to free any memory allocated by internal_pack as it will
5980 be freed at the end of the function by pop_context. */
5981 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5983 gfc_restore_backend_locus (&loc);
5987 /* Calculate the overall offset, including subreferences. */
5989 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5990 bool subref, gfc_expr *expr)
6000 /* If offset is NULL and this is not a subreferenced array, there is
6002 if (offset == NULL_TREE)
6005 offset = gfc_index_zero_node;
6010 tmp = gfc_conv_array_data (desc);
6011 tmp = build_fold_indirect_ref_loc (input_location,
6013 tmp = gfc_build_array_ref (tmp, offset, NULL);
6015 /* Offset the data pointer for pointer assignments from arrays with
6016 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6019 /* Go past the array reference. */
6020 for (ref = expr->ref; ref; ref = ref->next)
6021 if (ref->type == REF_ARRAY &&
6022 ref->u.ar.type != AR_ELEMENT)
6028 /* Calculate the offset for each subsequent subreference. */
6029 for (; ref; ref = ref->next)
6034 field = ref->u.c.component->backend_decl;
6035 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6036 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6038 tmp, field, NULL_TREE);
6042 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6043 gfc_init_se (&start, NULL);
6044 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6045 gfc_add_block_to_block (block, &start.pre);
6046 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6050 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6051 && ref->u.ar.type == AR_ELEMENT);
6053 /* TODO - Add bounds checking. */
6054 stride = gfc_index_one_node;
6055 index = gfc_index_zero_node;
6056 for (n = 0; n < ref->u.ar.dimen; n++)
6061 /* Update the index. */
6062 gfc_init_se (&start, NULL);
6063 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6064 itmp = gfc_evaluate_now (start.expr, block);
6065 gfc_init_se (&start, NULL);
6066 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6067 jtmp = gfc_evaluate_now (start.expr, block);
6068 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6069 gfc_array_index_type, itmp, jtmp);
6070 itmp = fold_build2_loc (input_location, MULT_EXPR,
6071 gfc_array_index_type, itmp, stride);
6072 index = fold_build2_loc (input_location, PLUS_EXPR,
6073 gfc_array_index_type, itmp, index);
6074 index = gfc_evaluate_now (index, block);
6076 /* Update the stride. */
6077 gfc_init_se (&start, NULL);
6078 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6079 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6080 gfc_array_index_type, start.expr,
6082 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6083 gfc_array_index_type,
6084 gfc_index_one_node, itmp);
6085 stride = fold_build2_loc (input_location, MULT_EXPR,
6086 gfc_array_index_type, stride, itmp);
6087 stride = gfc_evaluate_now (stride, block);
6090 /* Apply the index to obtain the array element. */
6091 tmp = gfc_build_array_ref (tmp, index, NULL);
6101 /* Set the target data pointer. */
6102 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6103 gfc_conv_descriptor_data_set (block, parm, offset);
6107 /* gfc_conv_expr_descriptor needs the string length an expression
6108 so that the size of the temporary can be obtained. This is done
6109 by adding up the string lengths of all the elements in the
6110 expression. Function with non-constant expressions have their
6111 string lengths mapped onto the actual arguments using the
6112 interface mapping machinery in trans-expr.c. */
6114 get_array_charlen (gfc_expr *expr, gfc_se *se)
6116 gfc_interface_mapping mapping;
6117 gfc_formal_arglist *formal;
6118 gfc_actual_arglist *arg;
6121 if (expr->ts.u.cl->length
6122 && gfc_is_constant_expr (expr->ts.u.cl->length))
6124 if (!expr->ts.u.cl->backend_decl)
6125 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6129 switch (expr->expr_type)
6132 get_array_charlen (expr->value.op.op1, se);
6134 /* For parentheses the expression ts.u.cl is identical. */
6135 if (expr->value.op.op == INTRINSIC_PARENTHESES)
6138 expr->ts.u.cl->backend_decl =
6139 gfc_create_var (gfc_charlen_type_node, "sln");
6141 if (expr->value.op.op2)
6143 get_array_charlen (expr->value.op.op2, se);
6145 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
6147 /* Add the string lengths and assign them to the expression
6148 string length backend declaration. */
6149 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6150 fold_build2_loc (input_location, PLUS_EXPR,
6151 gfc_charlen_type_node,
6152 expr->value.op.op1->ts.u.cl->backend_decl,
6153 expr->value.op.op2->ts.u.cl->backend_decl));
6156 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6157 expr->value.op.op1->ts.u.cl->backend_decl);
6161 if (expr->value.function.esym == NULL
6162 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6164 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6168 /* Map expressions involving the dummy arguments onto the actual
6169 argument expressions. */
6170 gfc_init_interface_mapping (&mapping);
6171 formal = expr->symtree->n.sym->formal;
6172 arg = expr->value.function.actual;
6174 /* Set se = NULL in the calls to the interface mapping, to suppress any
6176 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
6181 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
6184 gfc_init_se (&tse, NULL);
6186 /* Build the expression for the character length and convert it. */
6187 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
6189 gfc_add_block_to_block (&se->pre, &tse.pre);
6190 gfc_add_block_to_block (&se->post, &tse.post);
6191 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
6192 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
6193 gfc_charlen_type_node, tse.expr,
6194 build_int_cst (gfc_charlen_type_node, 0));
6195 expr->ts.u.cl->backend_decl = tse.expr;
6196 gfc_free_interface_mapping (&mapping);
6200 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6206 /* Helper function to check dimensions. */
6208 transposed_dims (gfc_ss *ss)
6212 for (n = 0; n < ss->dimen; n++)
6213 if (ss->dim[n] != n)
6218 /* Convert an array for passing as an actual argument. Expressions and
6219 vector subscripts are evaluated and stored in a temporary, which is then
6220 passed. For whole arrays the descriptor is passed. For array sections
6221 a modified copy of the descriptor is passed, but using the original data.
6223 This function is also used for array pointer assignments, and there
6226 - se->want_pointer && !se->direct_byref
6227 EXPR is an actual argument. On exit, se->expr contains a
6228 pointer to the array descriptor.
6230 - !se->want_pointer && !se->direct_byref
6231 EXPR is an actual argument to an intrinsic function or the
6232 left-hand side of a pointer assignment. On exit, se->expr
6233 contains the descriptor for EXPR.
6235 - !se->want_pointer && se->direct_byref
6236 EXPR is the right-hand side of a pointer assignment and
6237 se->expr is the descriptor for the previously-evaluated
6238 left-hand side. The function creates an assignment from
6242 The se->force_tmp flag disables the non-copying descriptor optimization
6243 that is used for transpose. It may be used in cases where there is an
6244 alias between the transpose argument and another argument in the same
6248 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
6250 gfc_ss_type ss_type;
6251 gfc_ss_info *ss_info;
6253 gfc_array_info *info;
6262 bool subref_array_target = false;
6263 gfc_expr *arg, *ss_expr;
6265 gcc_assert (ss != NULL);
6266 gcc_assert (ss != gfc_ss_terminator);
6269 ss_type = ss_info->type;
6270 ss_expr = ss_info->expr;
6272 /* Special case things we know we can pass easily. */
6273 switch (expr->expr_type)
6276 /* If we have a linear array section, we can pass it directly.
6277 Otherwise we need to copy it into a temporary. */
6279 gcc_assert (ss_type == GFC_SS_SECTION);
6280 gcc_assert (ss_expr == expr);
6281 info = &ss_info->data.array;
6283 /* Get the descriptor for the array. */
6284 gfc_conv_ss_descriptor (&se->pre, ss, 0);
6285 desc = info->descriptor;
6287 subref_array_target = se->direct_byref && is_subref_array (expr);
6288 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
6289 && !subref_array_target;
6296 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6298 /* Create a new descriptor if the array doesn't have one. */
6301 else if (info->ref->u.ar.type == AR_FULL)
6303 else if (se->direct_byref)
6306 full = gfc_full_array_ref_p (info->ref, NULL);
6308 if (full && !transposed_dims (ss))
6310 if (se->direct_byref && !se->byref_noassign)
6312 /* Copy the descriptor for pointer assignments. */
6313 gfc_add_modify (&se->pre, se->expr, desc);
6315 /* Add any offsets from subreferences. */
6316 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
6317 subref_array_target, expr);
6319 else if (se->want_pointer)
6321 /* We pass full arrays directly. This means that pointers and
6322 allocatable arrays should also work. */
6323 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6330 if (expr->ts.type == BT_CHARACTER)
6331 se->string_length = gfc_get_expr_charlen (expr);
6339 /* We don't need to copy data in some cases. */
6340 arg = gfc_get_noncopying_intrinsic_argument (expr);
6343 /* This is a call to transpose... */
6344 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6345 /* ... which has already been handled by the scalarizer, so
6346 that we just need to get its argument's descriptor. */
6347 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
6351 /* A transformational function return value will be a temporary
6352 array descriptor. We still need to go through the scalarizer
6353 to create the descriptor. Elemental functions ar handled as
6354 arbitrary expressions, i.e. copy to a temporary. */
6356 if (se->direct_byref)
6358 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
6360 /* For pointer assignments pass the descriptor directly. */
6364 gcc_assert (se->ss == ss);
6365 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6366 gfc_conv_expr (se, expr);
6370 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
6372 if (ss_expr != expr)
6373 /* Elemental function. */
6374 gcc_assert ((expr->value.function.esym != NULL
6375 && expr->value.function.esym->attr.elemental)
6376 || (expr->value.function.isym != NULL
6377 && expr->value.function.isym->elemental)
6378 || gfc_inline_intrinsic_function_p (expr));
6380 gcc_assert (ss_type == GFC_SS_INTRINSIC);
6383 if (expr->ts.type == BT_CHARACTER
6384 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6385 get_array_charlen (expr, se);
6391 /* Transformational function. */
6392 info = &ss_info->data.array;
6398 /* Constant array constructors don't need a temporary. */
6399 if (ss_type == GFC_SS_CONSTRUCTOR
6400 && expr->ts.type != BT_CHARACTER
6401 && gfc_constant_array_constructor_p (expr->value.constructor))
6404 info = &ss_info->data.array;
6414 /* Something complicated. Copy it into a temporary. */
6420 /* If we are creating a temporary, we don't need to bother about aliases
6425 gfc_init_loopinfo (&loop);
6427 /* Associate the SS with the loop. */
6428 gfc_add_ss_to_loop (&loop, ss);
6430 /* Tell the scalarizer not to bother creating loop variables, etc. */
6432 loop.array_parameter = 1;
6434 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6435 gcc_assert (!se->direct_byref);
6437 /* Setup the scalarizing loops and bounds. */
6438 gfc_conv_ss_startstride (&loop);
6442 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6443 get_array_charlen (expr, se);
6445 /* Tell the scalarizer to make a temporary. */
6446 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6447 ((expr->ts.type == BT_CHARACTER)
6448 ? expr->ts.u.cl->backend_decl
6452 se->string_length = loop.temp_ss->info->string_length;
6453 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6454 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6457 gfc_conv_loop_setup (&loop, & expr->where);
6461 /* Copy into a temporary and pass that. We don't need to copy the data
6462 back because expressions and vector subscripts must be INTENT_IN. */
6463 /* TODO: Optimize passing function return values. */
6467 /* Start the copying loops. */
6468 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6469 gfc_mark_ss_chain_used (ss, 1);
6470 gfc_start_scalarized_body (&loop, &block);
6472 /* Copy each data element. */
6473 gfc_init_se (&lse, NULL);
6474 gfc_copy_loopinfo_to_se (&lse, &loop);
6475 gfc_init_se (&rse, NULL);
6476 gfc_copy_loopinfo_to_se (&rse, &loop);
6478 lse.ss = loop.temp_ss;
6481 gfc_conv_scalarized_array_ref (&lse, NULL);
6482 if (expr->ts.type == BT_CHARACTER)
6484 gfc_conv_expr (&rse, expr);
6485 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6486 rse.expr = build_fold_indirect_ref_loc (input_location,
6490 gfc_conv_expr_val (&rse, expr);
6492 gfc_add_block_to_block (&block, &rse.pre);
6493 gfc_add_block_to_block (&block, &lse.pre);
6495 lse.string_length = rse.string_length;
6496 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6497 expr->expr_type == EXPR_VARIABLE
6498 || expr->expr_type == EXPR_ARRAY, true);
6499 gfc_add_expr_to_block (&block, tmp);
6501 /* Finish the copying loops. */
6502 gfc_trans_scalarizing_loops (&loop, &block);
6504 desc = loop.temp_ss->info->data.array.descriptor;
6506 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6508 desc = info->descriptor;
6509 se->string_length = ss_info->string_length;
6513 /* We pass sections without copying to a temporary. Make a new
6514 descriptor and point it at the section we want. The loop variable
6515 limits will be the limits of the section.
6516 A function may decide to repack the array to speed up access, but
6517 we're not bothered about that here. */
6518 int dim, ndim, codim;
6526 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6528 if (se->want_coarray)
6530 gfc_array_ref *ar = &info->ref->u.ar;
6532 codim = gfc_get_corank (expr);
6533 for (n = 0; n < codim - 1; n++)
6535 /* Make sure we are not lost somehow. */
6536 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6538 /* Make sure the call to gfc_conv_section_startstride won't
6539 generate unnecessary code to calculate stride. */
6540 gcc_assert (ar->stride[n + ndim] == NULL);
6542 gfc_conv_section_startstride (&loop, ss, n + ndim);
6543 loop.from[n + loop.dimen] = info->start[n + ndim];
6544 loop.to[n + loop.dimen] = info->end[n + ndim];
6547 gcc_assert (n == codim - 1);
6548 evaluate_bound (&loop.pre, info->start, ar->start,
6549 info->descriptor, n + ndim, true);
6550 loop.from[n + loop.dimen] = info->start[n + ndim];
6555 /* Set the string_length for a character array. */
6556 if (expr->ts.type == BT_CHARACTER)
6557 se->string_length = gfc_get_expr_charlen (expr);
6559 desc = info->descriptor;
6560 if (se->direct_byref && !se->byref_noassign)
6562 /* For pointer assignments we fill in the destination. */
6564 parmtype = TREE_TYPE (parm);
6568 /* Otherwise make a new one. */
6569 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6570 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6571 loop.from, loop.to, 0,
6572 GFC_ARRAY_UNKNOWN, false);
6573 parm = gfc_create_var (parmtype, "parm");
6576 offset = gfc_index_zero_node;
6578 /* The following can be somewhat confusing. We have two
6579 descriptors, a new one and the original array.
6580 {parm, parmtype, dim} refer to the new one.
6581 {desc, type, n, loop} refer to the original, which maybe
6582 a descriptorless array.
6583 The bounds of the scalarization are the bounds of the section.
6584 We don't have to worry about numeric overflows when calculating
6585 the offsets because all elements are within the array data. */
6587 /* Set the dtype. */
6588 tmp = gfc_conv_descriptor_dtype (parm);
6589 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6591 /* Set offset for assignments to pointer only to zero if it is not
6593 if (se->direct_byref
6594 && info->ref && info->ref->u.ar.type != AR_FULL)
6595 base = gfc_index_zero_node;
6596 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6597 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6601 for (n = 0; n < ndim; n++)
6603 stride = gfc_conv_array_stride (desc, n);
6605 /* Work out the offset. */
6607 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6609 gcc_assert (info->subscript[n]
6610 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6611 start = info->subscript[n]->info->data.scalar.value;
6615 /* Evaluate and remember the start of the section. */
6616 start = info->start[n];
6617 stride = gfc_evaluate_now (stride, &loop.pre);
6620 tmp = gfc_conv_array_lbound (desc, n);
6621 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6623 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6625 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6629 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6631 /* For elemental dimensions, we only need the offset. */
6635 /* Vector subscripts need copying and are handled elsewhere. */
6637 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6639 /* look for the corresponding scalarizer dimension: dim. */
6640 for (dim = 0; dim < ndim; dim++)
6641 if (ss->dim[dim] == n)
6644 /* loop exited early: the DIM being looked for has been found. */
6645 gcc_assert (dim < ndim);
6647 /* Set the new lower bound. */
6648 from = loop.from[dim];
6651 /* If we have an array section or are assigning make sure that
6652 the lower bound is 1. References to the full
6653 array should otherwise keep the original bounds. */
6655 || info->ref->u.ar.type != AR_FULL)
6656 && !integer_onep (from))
6658 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6659 gfc_array_index_type, gfc_index_one_node,
6661 to = fold_build2_loc (input_location, PLUS_EXPR,
6662 gfc_array_index_type, to, tmp);
6663 from = gfc_index_one_node;
6665 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6666 gfc_rank_cst[dim], from);
6668 /* Set the new upper bound. */
6669 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6670 gfc_rank_cst[dim], to);
6672 /* Multiply the stride by the section stride to get the
6674 stride = fold_build2_loc (input_location, MULT_EXPR,
6675 gfc_array_index_type,
6676 stride, info->stride[n]);
6678 if (se->direct_byref
6680 && info->ref->u.ar.type != AR_FULL)
6682 base = fold_build2_loc (input_location, MINUS_EXPR,
6683 TREE_TYPE (base), base, stride);
6685 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6687 tmp = gfc_conv_array_lbound (desc, n);
6688 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6689 TREE_TYPE (base), tmp, loop.from[dim]);
6690 tmp = fold_build2_loc (input_location, MULT_EXPR,
6691 TREE_TYPE (base), tmp,
6692 gfc_conv_array_stride (desc, n));
6693 base = fold_build2_loc (input_location, PLUS_EXPR,
6694 TREE_TYPE (base), tmp, base);
6697 /* Store the new stride. */
6698 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6699 gfc_rank_cst[dim], stride);
6702 for (n = loop.dimen; n < loop.dimen + codim; n++)
6704 from = loop.from[n];
6706 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6707 gfc_rank_cst[n], from);
6708 if (n < loop.dimen + codim - 1)
6709 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6710 gfc_rank_cst[n], to);
6713 if (se->data_not_needed)
6714 gfc_conv_descriptor_data_set (&loop.pre, parm,
6715 gfc_index_zero_node);
6717 /* Point the data pointer at the 1st element in the section. */
6718 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6719 subref_array_target, expr);
6721 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6722 && !se->data_not_needed)
6724 /* Set the offset. */
6725 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6729 /* Only the callee knows what the correct offset it, so just set
6731 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6736 if (!se->direct_byref || se->byref_noassign)
6738 /* Get a pointer to the new descriptor. */
6739 if (se->want_pointer)
6740 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6745 gfc_add_block_to_block (&se->pre, &loop.pre);
6746 gfc_add_block_to_block (&se->post, &loop.post);
6748 /* Cleanup the scalarizer. */
6749 gfc_cleanup_loop (&loop);
6752 /* Helper function for gfc_conv_array_parameter if array size needs to be
6756 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6759 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6760 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6761 else if (expr->rank > 1)
6762 *size = build_call_expr_loc (input_location,
6763 gfor_fndecl_size0, 1,
6764 gfc_build_addr_expr (NULL, desc));
6767 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6768 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6770 *size = fold_build2_loc (input_location, MINUS_EXPR,
6771 gfc_array_index_type, ubound, lbound);
6772 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6773 *size, gfc_index_one_node);
6774 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6775 *size, gfc_index_zero_node);
6777 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6778 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6779 *size, fold_convert (gfc_array_index_type, elem));
6782 /* Convert an array for passing as an actual parameter. */
6783 /* TODO: Optimize passing g77 arrays. */
6786 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6787 const gfc_symbol *fsym, const char *proc_name,
6792 tree tmp = NULL_TREE;
6794 tree parent = DECL_CONTEXT (current_function_decl);
6795 bool full_array_var;
6796 bool this_array_result;
6799 bool array_constructor;
6800 bool good_allocatable;
6801 bool ultimate_ptr_comp;
6802 bool ultimate_alloc_comp;
6807 ultimate_ptr_comp = false;
6808 ultimate_alloc_comp = false;
6810 for (ref = expr->ref; ref; ref = ref->next)
6812 if (ref->next == NULL)
6815 if (ref->type == REF_COMPONENT)
6817 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6818 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6822 full_array_var = false;
6825 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6826 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6828 sym = full_array_var ? expr->symtree->n.sym : NULL;
6830 /* The symbol should have an array specification. */
6831 gcc_assert (!sym || sym->as || ref->u.ar.as);
6833 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6835 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6836 expr->ts.u.cl->backend_decl = tmp;
6837 se->string_length = tmp;
6840 /* Is this the result of the enclosing procedure? */
6841 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6842 if (this_array_result
6843 && (sym->backend_decl != current_function_decl)
6844 && (sym->backend_decl != parent))
6845 this_array_result = false;
6847 /* Passing address of the array if it is not pointer or assumed-shape. */
6848 if (full_array_var && g77 && !this_array_result)
6850 tmp = gfc_get_symbol_decl (sym);
6852 if (sym->ts.type == BT_CHARACTER)
6853 se->string_length = sym->ts.u.cl->backend_decl;
6855 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6857 gfc_conv_expr_descriptor (se, expr, ss);
6858 se->expr = gfc_conv_array_data (se->expr);
6862 if (!sym->attr.pointer
6864 && sym->as->type != AS_ASSUMED_SHAPE
6865 && !sym->attr.allocatable)
6867 /* Some variables are declared directly, others are declared as
6868 pointers and allocated on the heap. */
6869 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6872 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6874 array_parameter_size (tmp, expr, size);
6878 if (sym->attr.allocatable)
6880 if (sym->attr.dummy || sym->attr.result)
6882 gfc_conv_expr_descriptor (se, expr, ss);
6886 array_parameter_size (tmp, expr, size);
6887 se->expr = gfc_conv_array_data (tmp);
6892 /* A convenient reduction in scope. */
6893 contiguous = g77 && !this_array_result && contiguous;
6895 /* There is no need to pack and unpack the array, if it is contiguous
6896 and not a deferred- or assumed-shape array, or if it is simply
6898 no_pack = ((sym && sym->as
6899 && !sym->attr.pointer
6900 && sym->as->type != AS_DEFERRED
6901 && sym->as->type != AS_ASSUMED_SHAPE)
6903 (ref && ref->u.ar.as
6904 && ref->u.ar.as->type != AS_DEFERRED
6905 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6907 gfc_is_simply_contiguous (expr, false));
6909 no_pack = contiguous && no_pack;
6911 /* Array constructors are always contiguous and do not need packing. */
6912 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6914 /* Same is true of contiguous sections from allocatable variables. */
6915 good_allocatable = contiguous
6917 && expr->symtree->n.sym->attr.allocatable;
6919 /* Or ultimate allocatable components. */
6920 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6922 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6924 gfc_conv_expr_descriptor (se, expr, ss);
6925 if (expr->ts.type == BT_CHARACTER)
6926 se->string_length = expr->ts.u.cl->backend_decl;
6928 array_parameter_size (se->expr, expr, size);
6929 se->expr = gfc_conv_array_data (se->expr);
6933 if (this_array_result)
6935 /* Result of the enclosing function. */
6936 gfc_conv_expr_descriptor (se, expr, ss);
6938 array_parameter_size (se->expr, expr, size);
6939 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6941 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6942 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6943 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6950 /* Every other type of array. */
6951 se->want_pointer = 1;
6952 gfc_conv_expr_descriptor (se, expr, ss);
6954 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6959 /* Deallocate the allocatable components of structures that are
6961 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6962 && expr->ts.u.derived->attr.alloc_comp
6963 && expr->expr_type != EXPR_VARIABLE)
6965 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6966 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6968 /* The components shall be deallocated before their containing entity. */
6969 gfc_prepend_expr_to_block (&se->post, tmp);
6972 if (g77 || (fsym && fsym->attr.contiguous
6973 && !gfc_is_simply_contiguous (expr, false)))
6975 tree origptr = NULL_TREE;
6979 /* For contiguous arrays, save the original value of the descriptor. */
6982 origptr = gfc_create_var (pvoid_type_node, "origptr");
6983 tmp = build_fold_indirect_ref_loc (input_location, desc);
6984 tmp = gfc_conv_array_data (tmp);
6985 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6986 TREE_TYPE (origptr), origptr,
6987 fold_convert (TREE_TYPE (origptr), tmp));
6988 gfc_add_expr_to_block (&se->pre, tmp);
6991 /* Repack the array. */
6992 if (gfc_option.warn_array_temp)
6995 gfc_warning ("Creating array temporary at %L for argument '%s'",
6996 &expr->where, fsym->name);
6998 gfc_warning ("Creating array temporary at %L", &expr->where);
7001 ptr = build_call_expr_loc (input_location,
7002 gfor_fndecl_in_pack, 1, desc);
7004 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7006 tmp = gfc_conv_expr_present (sym);
7007 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
7008 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
7009 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
7012 ptr = gfc_evaluate_now (ptr, &se->pre);
7014 /* Use the packed data for the actual argument, except for contiguous arrays,
7015 where the descriptor's data component is set. */
7020 tmp = build_fold_indirect_ref_loc (input_location, desc);
7021 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
7024 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
7028 if (fsym && proc_name)
7029 asprintf (&msg, "An array temporary was created for argument "
7030 "'%s' of procedure '%s'", fsym->name, proc_name);
7032 asprintf (&msg, "An array temporary was created");
7034 tmp = build_fold_indirect_ref_loc (input_location,
7036 tmp = gfc_conv_array_data (tmp);
7037 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7038 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7040 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7041 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7043 gfc_conv_expr_present (sym), tmp);
7045 gfc_trans_runtime_check (false, true, tmp, &se->pre,
7050 gfc_start_block (&block);
7052 /* Copy the data back. */
7053 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
7055 tmp = build_call_expr_loc (input_location,
7056 gfor_fndecl_in_unpack, 2, desc, ptr);
7057 gfc_add_expr_to_block (&block, tmp);
7060 /* Free the temporary. */
7061 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
7062 gfc_add_expr_to_block (&block, tmp);
7064 stmt = gfc_finish_block (&block);
7066 gfc_init_block (&block);
7067 /* Only if it was repacked. This code needs to be executed before the
7068 loop cleanup code. */
7069 tmp = build_fold_indirect_ref_loc (input_location,
7071 tmp = gfc_conv_array_data (tmp);
7072 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7073 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7075 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7076 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7078 gfc_conv_expr_present (sym), tmp);
7080 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
7082 gfc_add_expr_to_block (&block, tmp);
7083 gfc_add_block_to_block (&block, &se->post);
7085 gfc_init_block (&se->post);
7087 /* Reset the descriptor pointer. */
7090 tmp = build_fold_indirect_ref_loc (input_location, desc);
7091 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
7094 gfc_add_block_to_block (&se->post, &block);
7099 /* Generate code to deallocate an array, if it is allocated. */
7102 gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
7108 gfc_start_block (&block);
7110 var = gfc_conv_descriptor_data_get (descriptor);
7113 /* Call array_deallocate with an int * present in the second argument.
7114 Although it is ignored here, it's presence ensures that arrays that
7115 are already deallocated are ignored. */
7116 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
7117 NULL_TREE, NULL_TREE, NULL_TREE, true,
7119 gfc_add_expr_to_block (&block, tmp);
7121 /* Zero the data pointer. */
7122 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7123 var, build_int_cst (TREE_TYPE (var), 0));
7124 gfc_add_expr_to_block (&block, tmp);
7126 return gfc_finish_block (&block);
7130 /* This helper function calculates the size in words of a full array. */
7133 get_full_array_size (stmtblock_t *block, tree decl, int rank)
7138 idx = gfc_rank_cst[rank - 1];
7139 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
7140 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
7141 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7143 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7144 tmp, gfc_index_one_node);
7145 tmp = gfc_evaluate_now (tmp, block);
7147 nelems = gfc_conv_descriptor_stride_get (decl, idx);
7148 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7150 return gfc_evaluate_now (tmp, block);
7154 /* Allocate dest to the same size as src, and copy src -> dest.
7155 If no_malloc is set, only the copy is done. */
7158 duplicate_allocatable (tree dest, tree src, tree type, int rank,
7168 /* If the source is null, set the destination to null. Then,
7169 allocate memory to the destination. */
7170 gfc_init_block (&block);
7174 tmp = null_pointer_node;
7175 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
7176 gfc_add_expr_to_block (&block, tmp);
7177 null_data = gfc_finish_block (&block);
7179 gfc_init_block (&block);
7180 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7183 tmp = gfc_call_malloc (&block, type, size);
7184 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7185 dest, fold_convert (type, tmp));
7186 gfc_add_expr_to_block (&block, tmp);
7189 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7190 tmp = build_call_expr_loc (input_location, tmp, 3,
7195 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7196 null_data = gfc_finish_block (&block);
7198 gfc_init_block (&block);
7199 nelems = get_full_array_size (&block, src, rank);
7200 tmp = fold_convert (gfc_array_index_type,
7201 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7202 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7206 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
7207 tmp = gfc_call_malloc (&block, tmp, size);
7208 gfc_conv_descriptor_data_set (&block, dest, tmp);
7211 /* We know the temporary and the value will be the same length,
7212 so can use memcpy. */
7213 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7214 tmp = build_call_expr_loc (input_location,
7215 tmp, 3, gfc_conv_descriptor_data_get (dest),
7216 gfc_conv_descriptor_data_get (src), size);
7219 gfc_add_expr_to_block (&block, tmp);
7220 tmp = gfc_finish_block (&block);
7222 /* Null the destination if the source is null; otherwise do
7223 the allocate and copy. */
7227 null_cond = gfc_conv_descriptor_data_get (src);
7229 null_cond = convert (pvoid_type_node, null_cond);
7230 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7231 null_cond, null_pointer_node);
7232 return build3_v (COND_EXPR, null_cond, tmp, null_data);
7236 /* Allocate dest to the same size as src, and copy data src -> dest. */
7239 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
7241 return duplicate_allocatable (dest, src, type, rank, false);
7245 /* Copy data src -> dest. */
7248 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
7250 return duplicate_allocatable (dest, src, type, rank, true);
7254 /* Recursively traverse an object of derived type, generating code to
7255 deallocate, nullify or copy allocatable components. This is the work horse
7256 function for the functions named in this enum. */
7258 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
7259 COPY_ONLY_ALLOC_COMP};
7262 structure_alloc_comps (gfc_symbol * der_type, tree decl,
7263 tree dest, int rank, int purpose)
7267 stmtblock_t fnblock;
7268 stmtblock_t loopbody;
7269 stmtblock_t tmpblock;
7280 tree null_cond = NULL_TREE;
7281 bool called_dealloc_with_status;
7283 gfc_init_block (&fnblock);
7285 decl_type = TREE_TYPE (decl);
7287 if ((POINTER_TYPE_P (decl_type) && rank != 0)
7288 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
7290 decl = build_fold_indirect_ref_loc (input_location,
7293 /* Just in case in gets dereferenced. */
7294 decl_type = TREE_TYPE (decl);
7296 /* If this an array of derived types with allocatable components
7297 build a loop and recursively call this function. */
7298 if (TREE_CODE (decl_type) == ARRAY_TYPE
7299 || GFC_DESCRIPTOR_TYPE_P (decl_type))
7301 tmp = gfc_conv_array_data (decl);
7302 var = build_fold_indirect_ref_loc (input_location,
7305 /* Get the number of elements - 1 and set the counter. */
7306 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
7308 /* Use the descriptor for an allocatable array. Since this
7309 is a full array reference, we only need the descriptor
7310 information from dimension = rank. */
7311 tmp = get_full_array_size (&fnblock, decl, rank);
7312 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7313 gfc_array_index_type, tmp,
7314 gfc_index_one_node);
7316 null_cond = gfc_conv_descriptor_data_get (decl);
7317 null_cond = fold_build2_loc (input_location, NE_EXPR,
7318 boolean_type_node, null_cond,
7319 build_int_cst (TREE_TYPE (null_cond), 0));
7323 /* Otherwise use the TYPE_DOMAIN information. */
7324 tmp = array_type_nelts (decl_type);
7325 tmp = fold_convert (gfc_array_index_type, tmp);
7328 /* Remember that this is, in fact, the no. of elements - 1. */
7329 nelems = gfc_evaluate_now (tmp, &fnblock);
7330 index = gfc_create_var (gfc_array_index_type, "S");
7332 /* Build the body of the loop. */
7333 gfc_init_block (&loopbody);
7335 vref = gfc_build_array_ref (var, index, NULL);
7337 if (purpose == COPY_ALLOC_COMP)
7339 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7341 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
7342 gfc_add_expr_to_block (&fnblock, tmp);
7344 tmp = build_fold_indirect_ref_loc (input_location,
7345 gfc_conv_array_data (dest));
7346 dref = gfc_build_array_ref (tmp, index, NULL);
7347 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
7349 else if (purpose == COPY_ONLY_ALLOC_COMP)
7351 tmp = build_fold_indirect_ref_loc (input_location,
7352 gfc_conv_array_data (dest));
7353 dref = gfc_build_array_ref (tmp, index, NULL);
7354 tmp = structure_alloc_comps (der_type, vref, dref, rank,
7358 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
7360 gfc_add_expr_to_block (&loopbody, tmp);
7362 /* Build the loop and return. */
7363 gfc_init_loopinfo (&loop);
7365 loop.from[0] = gfc_index_zero_node;
7366 loop.loopvar[0] = index;
7367 loop.to[0] = nelems;
7368 gfc_trans_scalarizing_loops (&loop, &loopbody);
7369 gfc_add_block_to_block (&fnblock, &loop.pre);
7371 tmp = gfc_finish_block (&fnblock);
7372 if (null_cond != NULL_TREE)
7373 tmp = build3_v (COND_EXPR, null_cond, tmp,
7374 build_empty_stmt (input_location));
7379 /* Otherwise, act on the components or recursively call self to
7380 act on a chain of components. */
7381 for (c = der_type->components; c; c = c->next)
7383 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
7384 || c->ts.type == BT_CLASS)
7385 && c->ts.u.derived->attr.alloc_comp;
7386 cdecl = c->backend_decl;
7387 ctype = TREE_TYPE (cdecl);
7391 case DEALLOCATE_ALLOC_COMP:
7393 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7394 (ie. this function) so generate all the calls and suppress the
7395 recursion from here, if necessary. */
7396 called_dealloc_with_status = false;
7397 gfc_init_block (&tmpblock);
7399 if (c->attr.allocatable
7400 && (c->attr.dimension || c->attr.codimension))
7402 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7403 decl, cdecl, NULL_TREE);
7404 tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
7405 gfc_add_expr_to_block (&tmpblock, tmp);
7407 else if (c->attr.allocatable)
7409 /* Allocatable scalar components. */
7410 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7411 decl, cdecl, NULL_TREE);
7413 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7415 gfc_add_expr_to_block (&tmpblock, tmp);
7416 called_dealloc_with_status = true;
7418 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7419 void_type_node, comp,
7420 build_int_cst (TREE_TYPE (comp), 0));
7421 gfc_add_expr_to_block (&tmpblock, tmp);
7423 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7425 /* Allocatable CLASS components. */
7426 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7427 decl, cdecl, NULL_TREE);
7429 /* Add reference to '_data' component. */
7430 tmp = CLASS_DATA (c)->backend_decl;
7431 comp = fold_build3_loc (input_location, COMPONENT_REF,
7432 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7434 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
7435 tmp = gfc_trans_dealloc_allocated (comp,
7436 CLASS_DATA (c)->attr.codimension);
7439 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7440 CLASS_DATA (c)->ts);
7441 gfc_add_expr_to_block (&tmpblock, tmp);
7442 called_dealloc_with_status = true;
7444 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7445 void_type_node, comp,
7446 build_int_cst (TREE_TYPE (comp), 0));
7448 gfc_add_expr_to_block (&tmpblock, tmp);
7451 if (cmp_has_alloc_comps
7453 && !called_dealloc_with_status)
7455 /* Do not deallocate the components of ultimate pointer
7456 components or iteratively call self if call has been made
7457 to gfc_trans_dealloc_allocated */
7458 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7459 decl, cdecl, NULL_TREE);
7460 rank = c->as ? c->as->rank : 0;
7461 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7463 gfc_add_expr_to_block (&fnblock, tmp);
7466 /* Now add the deallocation of this component. */
7467 gfc_add_block_to_block (&fnblock, &tmpblock);
7470 case NULLIFY_ALLOC_COMP:
7471 if (c->attr.pointer)
7473 else if (c->attr.allocatable
7474 && (c->attr.dimension|| c->attr.codimension))
7476 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7477 decl, cdecl, NULL_TREE);
7478 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7480 else if (c->attr.allocatable)
7482 /* Allocatable scalar components. */
7483 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7484 decl, cdecl, NULL_TREE);
7485 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7486 void_type_node, comp,
7487 build_int_cst (TREE_TYPE (comp), 0));
7488 gfc_add_expr_to_block (&fnblock, tmp);
7490 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7492 /* Allocatable CLASS components. */
7493 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7494 decl, cdecl, NULL_TREE);
7495 /* Add reference to '_data' component. */
7496 tmp = CLASS_DATA (c)->backend_decl;
7497 comp = fold_build3_loc (input_location, COMPONENT_REF,
7498 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7499 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
7500 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7503 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7504 void_type_node, comp,
7505 build_int_cst (TREE_TYPE (comp), 0));
7506 gfc_add_expr_to_block (&fnblock, tmp);
7509 else if (cmp_has_alloc_comps)
7511 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7512 decl, cdecl, NULL_TREE);
7513 rank = c->as ? c->as->rank : 0;
7514 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7516 gfc_add_expr_to_block (&fnblock, tmp);
7520 case COPY_ALLOC_COMP:
7521 if (c->attr.pointer)
7524 /* We need source and destination components. */
7525 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7527 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7529 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7531 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7539 dst_data = gfc_class_data_get (dcmp);
7540 src_data = gfc_class_data_get (comp);
7541 size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
7543 if (CLASS_DATA (c)->attr.dimension)
7545 nelems = gfc_conv_descriptor_size (src_data,
7546 CLASS_DATA (c)->as->rank);
7547 src_data = gfc_conv_descriptor_data_get (src_data);
7548 dst_data = gfc_conv_descriptor_data_get (dst_data);
7551 nelems = build_int_cst (size_type_node, 1);
7553 gfc_init_block (&tmpblock);
7555 /* We need to use CALLOC as _copy might try to free allocatable
7556 components of the destination. */
7557 ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
7558 tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
7560 gfc_add_modify (&tmpblock, dst_data,
7561 fold_convert (TREE_TYPE (dst_data), tmp));
7563 tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
7564 gfc_add_expr_to_block (&tmpblock, tmp);
7565 tmp = gfc_finish_block (&tmpblock);
7567 gfc_init_block (&tmpblock);
7568 gfc_add_modify (&tmpblock, dst_data,
7569 fold_convert (TREE_TYPE (dst_data),
7570 null_pointer_node));
7571 null_data = gfc_finish_block (&tmpblock);
7573 null_cond = fold_build2_loc (input_location, NE_EXPR,
7574 boolean_type_node, src_data,
7577 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
7582 if (c->attr.allocatable && !cmp_has_alloc_comps)
7584 rank = c->as ? c->as->rank : 0;
7585 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7586 gfc_add_expr_to_block (&fnblock, tmp);
7589 if (cmp_has_alloc_comps)
7591 rank = c->as ? c->as->rank : 0;
7592 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7593 gfc_add_modify (&fnblock, dcmp, tmp);
7594 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7596 gfc_add_expr_to_block (&fnblock, tmp);
7606 return gfc_finish_block (&fnblock);
7609 /* Recursively traverse an object of derived type, generating code to
7610 nullify allocatable components. */
7613 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7615 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7616 NULLIFY_ALLOC_COMP);
7620 /* Recursively traverse an object of derived type, generating code to
7621 deallocate allocatable components. */
7624 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7626 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7627 DEALLOCATE_ALLOC_COMP);
7631 /* Recursively traverse an object of derived type, generating code to
7632 copy it and its allocatable components. */
7635 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7637 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7641 /* Recursively traverse an object of derived type, generating code to
7642 copy only its allocatable components. */
7645 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7647 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7651 /* Returns the value of LBOUND for an expression. This could be broken out
7652 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7653 called by gfc_alloc_allocatable_for_assignment. */
7655 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7660 tree cond, cond1, cond3, cond4;
7664 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7666 tmp = gfc_rank_cst[dim];
7667 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7668 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7669 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7670 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7672 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7673 stride, gfc_index_zero_node);
7674 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7675 boolean_type_node, cond3, cond1);
7676 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7677 stride, gfc_index_zero_node);
7679 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7680 tmp, build_int_cst (gfc_array_index_type,
7683 cond = boolean_false_node;
7685 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7686 boolean_type_node, cond3, cond4);
7687 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7688 boolean_type_node, cond, cond1);
7690 return fold_build3_loc (input_location, COND_EXPR,
7691 gfc_array_index_type, cond,
7692 lbound, gfc_index_one_node);
7695 if (expr->expr_type == EXPR_FUNCTION)
7697 /* A conversion function, so use the argument. */
7698 gcc_assert (expr->value.function.isym
7699 && expr->value.function.isym->conversion);
7700 expr = expr->value.function.actual->expr;
7703 if (expr->expr_type == EXPR_VARIABLE)
7705 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7706 for (ref = expr->ref; ref; ref = ref->next)
7708 if (ref->type == REF_COMPONENT
7709 && ref->u.c.component->as
7711 && ref->next->u.ar.type == AR_FULL)
7712 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7714 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7717 return gfc_index_one_node;
7721 /* Returns true if an expression represents an lhs that can be reallocated
7725 gfc_is_reallocatable_lhs (gfc_expr *expr)
7732 /* An allocatable variable. */
7733 if (expr->symtree->n.sym->attr.allocatable
7735 && expr->ref->type == REF_ARRAY
7736 && expr->ref->u.ar.type == AR_FULL)
7739 /* All that can be left are allocatable components. */
7740 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7741 && expr->symtree->n.sym->ts.type != BT_CLASS)
7742 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7745 /* Find a component ref followed by an array reference. */
7746 for (ref = expr->ref; ref; ref = ref->next)
7748 && ref->type == REF_COMPONENT
7749 && ref->next->type == REF_ARRAY
7750 && !ref->next->next)
7756 /* Return true if valid reallocatable lhs. */
7757 if (ref->u.c.component->attr.allocatable
7758 && ref->next->u.ar.type == AR_FULL)
7765 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7769 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7773 stmtblock_t realloc_block;
7774 stmtblock_t alloc_block;
7778 gfc_array_info *linfo;
7798 gfc_array_spec * as;
7800 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7801 Find the lhs expression in the loop chain and set expr1 and
7802 expr2 accordingly. */
7803 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7806 /* Find the ss for the lhs. */
7808 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7809 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
7811 if (lss == gfc_ss_terminator)
7813 expr1 = lss->info->expr;
7816 /* Bail out if this is not a valid allocate on assignment. */
7817 if (!gfc_is_reallocatable_lhs (expr1)
7818 || (expr2 && !expr2->rank))
7821 /* Find the ss for the lhs. */
7823 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7824 if (lss->info->expr == expr1)
7827 if (lss == gfc_ss_terminator)
7830 linfo = &lss->info->data.array;
7832 /* Find an ss for the rhs. For operator expressions, we see the
7833 ss's for the operands. Any one of these will do. */
7835 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7836 if (rss->info->expr != expr1 && rss != loop->temp_ss)
7839 if (expr2 && rss == gfc_ss_terminator)
7842 gfc_start_block (&fblock);
7844 /* Since the lhs is allocatable, this must be a descriptor type.
7845 Get the data and array size. */
7846 desc = linfo->descriptor;
7847 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7848 array1 = gfc_conv_descriptor_data_get (desc);
7850 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7851 deallocated if expr is an array of different shape or any of the
7852 corresponding length type parameter values of variable and expr
7853 differ." This assures F95 compatibility. */
7854 jump_label1 = gfc_build_label_decl (NULL_TREE);
7855 jump_label2 = gfc_build_label_decl (NULL_TREE);
7857 /* Allocate if data is NULL. */
7858 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7859 array1, build_int_cst (TREE_TYPE (array1), 0));
7860 tmp = build3_v (COND_EXPR, cond,
7861 build1_v (GOTO_EXPR, jump_label1),
7862 build_empty_stmt (input_location));
7863 gfc_add_expr_to_block (&fblock, tmp);
7865 /* Get arrayspec if expr is a full array. */
7866 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7867 && expr2->value.function.isym
7868 && expr2->value.function.isym->conversion)
7870 /* For conversion functions, take the arg. */
7871 gfc_expr *arg = expr2->value.function.actual->expr;
7872 as = gfc_get_full_arrayspec_from_expr (arg);
7875 as = gfc_get_full_arrayspec_from_expr (expr2);
7879 /* If the lhs shape is not the same as the rhs jump to setting the
7880 bounds and doing the reallocation....... */
7881 for (n = 0; n < expr1->rank; n++)
7883 /* Check the shape. */
7884 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7885 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7886 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7887 gfc_array_index_type,
7888 loop->to[n], loop->from[n]);
7889 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7890 gfc_array_index_type,
7892 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7893 gfc_array_index_type,
7895 cond = fold_build2_loc (input_location, NE_EXPR,
7897 tmp, gfc_index_zero_node);
7898 tmp = build3_v (COND_EXPR, cond,
7899 build1_v (GOTO_EXPR, jump_label1),
7900 build_empty_stmt (input_location));
7901 gfc_add_expr_to_block (&fblock, tmp);
7904 /* ....else jump past the (re)alloc code. */
7905 tmp = build1_v (GOTO_EXPR, jump_label2);
7906 gfc_add_expr_to_block (&fblock, tmp);
7908 /* Add the label to start automatic (re)allocation. */
7909 tmp = build1_v (LABEL_EXPR, jump_label1);
7910 gfc_add_expr_to_block (&fblock, tmp);
7912 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7914 /* Get the rhs size. Fix both sizes. */
7916 desc2 = rss->info->data.array.descriptor;
7919 size2 = gfc_index_one_node;
7920 for (n = 0; n < expr2->rank; n++)
7922 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7923 gfc_array_index_type,
7924 loop->to[n], loop->from[n]);
7925 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7926 gfc_array_index_type,
7927 tmp, gfc_index_one_node);
7928 size2 = fold_build2_loc (input_location, MULT_EXPR,
7929 gfc_array_index_type,
7933 size1 = gfc_evaluate_now (size1, &fblock);
7934 size2 = gfc_evaluate_now (size2, &fblock);
7936 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7938 neq_size = gfc_evaluate_now (cond, &fblock);
7941 /* Now modify the lhs descriptor and the associated scalarizer
7942 variables. F2003 7.4.1.3: "If variable is or becomes an
7943 unallocated allocatable variable, then it is allocated with each
7944 deferred type parameter equal to the corresponding type parameters
7945 of expr , with the shape of expr , and with each lower bound equal
7946 to the corresponding element of LBOUND(expr)."
7947 Reuse size1 to keep a dimension-by-dimension track of the
7948 stride of the new array. */
7949 size1 = gfc_index_one_node;
7950 offset = gfc_index_zero_node;
7952 for (n = 0; n < expr2->rank; n++)
7954 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7955 gfc_array_index_type,
7956 loop->to[n], loop->from[n]);
7957 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7958 gfc_array_index_type,
7959 tmp, gfc_index_one_node);
7961 lbound = gfc_index_one_node;
7966 lbd = get_std_lbound (expr2, desc2, n,
7967 as->type == AS_ASSUMED_SIZE);
7968 ubound = fold_build2_loc (input_location,
7970 gfc_array_index_type,
7972 ubound = fold_build2_loc (input_location,
7974 gfc_array_index_type,
7979 gfc_conv_descriptor_lbound_set (&fblock, desc,
7982 gfc_conv_descriptor_ubound_set (&fblock, desc,
7985 gfc_conv_descriptor_stride_set (&fblock, desc,
7988 lbound = gfc_conv_descriptor_lbound_get (desc,
7990 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7991 gfc_array_index_type,
7993 offset = fold_build2_loc (input_location, MINUS_EXPR,
7994 gfc_array_index_type,
7996 size1 = fold_build2_loc (input_location, MULT_EXPR,
7997 gfc_array_index_type,
8001 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8002 the array offset is saved and the info.offset is used for a
8003 running offset. Use the saved_offset instead. */
8004 tmp = gfc_conv_descriptor_offset (desc);
8005 gfc_add_modify (&fblock, tmp, offset);
8006 if (linfo->saved_offset
8007 && TREE_CODE (linfo->saved_offset) == VAR_DECL)
8008 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
8010 /* Now set the deltas for the lhs. */
8011 for (n = 0; n < expr1->rank; n++)
8013 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8015 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8016 gfc_array_index_type, tmp,
8018 if (linfo->delta[dim]
8019 && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
8020 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
8023 /* Get the new lhs size in bytes. */
8024 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
8026 tmp = expr2->ts.u.cl->backend_decl;
8027 gcc_assert (expr1->ts.u.cl->backend_decl);
8028 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
8029 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
8031 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
8033 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
8034 tmp = fold_build2_loc (input_location, MULT_EXPR,
8035 gfc_array_index_type, tmp,
8036 expr1->ts.u.cl->backend_decl);
8039 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
8040 tmp = fold_convert (gfc_array_index_type, tmp);
8041 size2 = fold_build2_loc (input_location, MULT_EXPR,
8042 gfc_array_index_type,
8044 size2 = fold_convert (size_type_node, size2);
8045 size2 = gfc_evaluate_now (size2, &fblock);
8047 /* Realloc expression. Note that the scalarizer uses desc.data
8048 in the array reference - (*desc.data)[<element>]. */
8049 gfc_init_block (&realloc_block);
8050 tmp = build_call_expr_loc (input_location,
8051 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
8052 fold_convert (pvoid_type_node, array1),
8054 gfc_conv_descriptor_data_set (&realloc_block,
8056 realloc_expr = gfc_finish_block (&realloc_block);
8058 /* Only reallocate if sizes are different. */
8059 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
8060 build_empty_stmt (input_location));
8064 /* Malloc expression. */
8065 gfc_init_block (&alloc_block);
8066 tmp = build_call_expr_loc (input_location,
8067 builtin_decl_explicit (BUILT_IN_MALLOC),
8069 gfc_conv_descriptor_data_set (&alloc_block,
8071 tmp = gfc_conv_descriptor_dtype (desc);
8072 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
8073 alloc_expr = gfc_finish_block (&alloc_block);
8075 /* Malloc if not allocated; realloc otherwise. */
8076 tmp = build_int_cst (TREE_TYPE (array1), 0);
8077 cond = fold_build2_loc (input_location, EQ_EXPR,
8080 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
8081 gfc_add_expr_to_block (&fblock, tmp);
8083 /* Make sure that the scalarizer data pointer is updated. */
8085 && TREE_CODE (linfo->data) == VAR_DECL)
8087 tmp = gfc_conv_descriptor_data_get (desc);
8088 gfc_add_modify (&fblock, linfo->data, tmp);
8091 /* Add the exit label. */
8092 tmp = build1_v (LABEL_EXPR, jump_label2);
8093 gfc_add_expr_to_block (&fblock, tmp);
8095 return gfc_finish_block (&fblock);
8099 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8100 Do likewise, recursively if necessary, with the allocatable components of
8104 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
8110 stmtblock_t cleanup;
8113 bool sym_has_alloc_comp;
8115 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
8116 || sym->ts.type == BT_CLASS)
8117 && sym->ts.u.derived->attr.alloc_comp;
8119 /* Make sure the frontend gets these right. */
8120 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
8121 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8122 "allocatable attribute or derived type without allocatable "
8125 gfc_save_backend_locus (&loc);
8126 gfc_set_backend_locus (&sym->declared_at);
8127 gfc_init_block (&init);
8129 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
8130 || TREE_CODE (sym->backend_decl) == PARM_DECL);
8132 if (sym->ts.type == BT_CHARACTER
8133 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
8135 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
8136 gfc_trans_vla_type_sizes (sym, &init);
8139 /* Dummy, use associated and result variables don't need anything special. */
8140 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
8142 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8143 gfc_restore_backend_locus (&loc);
8147 descriptor = sym->backend_decl;
8149 /* Although static, derived types with default initializers and
8150 allocatable components must not be nulled wholesale; instead they
8151 are treated component by component. */
8152 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
8154 /* SAVEd variables are not freed on exit. */
8155 gfc_trans_static_array_pointer (sym);
8157 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8158 gfc_restore_backend_locus (&loc);
8162 /* Get the descriptor type. */
8163 type = TREE_TYPE (sym->backend_decl);
8165 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
8168 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
8170 if (sym->value == NULL
8171 || !gfc_has_default_initializer (sym->ts.u.derived))
8173 rank = sym->as ? sym->as->rank : 0;
8174 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
8176 gfc_add_expr_to_block (&init, tmp);
8179 gfc_init_default_dt (sym, &init, false);
8182 else if (!GFC_DESCRIPTOR_TYPE_P (type))
8184 /* If the backend_decl is not a descriptor, we must have a pointer
8186 descriptor = build_fold_indirect_ref_loc (input_location,
8188 type = TREE_TYPE (descriptor);
8191 /* NULLIFY the data pointer. */
8192 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
8193 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
8195 gfc_restore_backend_locus (&loc);
8196 gfc_init_block (&cleanup);
8198 /* Allocatable arrays need to be freed when they go out of scope.
8199 The allocatable components of pointers must not be touched. */
8200 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
8201 && !sym->attr.pointer && !sym->attr.save)
8204 rank = sym->as ? sym->as->rank : 0;
8205 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
8206 gfc_add_expr_to_block (&cleanup, tmp);
8209 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
8210 && !sym->attr.save && !sym->attr.result)
8212 tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
8213 sym->attr.codimension);
8214 gfc_add_expr_to_block (&cleanup, tmp);
8217 gfc_add_init_cleanup (block, gfc_finish_block (&init),
8218 gfc_finish_block (&cleanup));
8221 /************ Expression Walking Functions ******************/
8223 /* Walk a variable reference.
8225 Possible extension - multiple component subscripts.
8226 x(:,:) = foo%a(:)%b(:)
8228 forall (i=..., j=...)
8229 x(i,j) = foo%a(j)%b(i)
8231 This adds a fair amount of complexity because you need to deal with more
8232 than one ref. Maybe handle in a similar manner to vector subscripts.
8233 Maybe not worth the effort. */
8237 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
8241 for (ref = expr->ref; ref; ref = ref->next)
8242 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
8245 return gfc_walk_array_ref (ss, expr, ref);
8250 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
8256 for (; ref; ref = ref->next)
8258 if (ref->type == REF_SUBSTRING)
8260 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
8261 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
8264 /* We're only interested in array sections from now on. */
8265 if (ref->type != REF_ARRAY)
8273 for (n = ar->dimen - 1; n >= 0; n--)
8274 ss = gfc_get_scalar_ss (ss, ar->start[n]);
8278 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
8279 newss->info->data.array.ref = ref;
8281 /* Make sure array is the same as array(:,:), this way
8282 we don't need to special case all the time. */
8283 ar->dimen = ar->as->rank;
8284 for (n = 0; n < ar->dimen; n++)
8286 ar->dimen_type[n] = DIMEN_RANGE;
8288 gcc_assert (ar->start[n] == NULL);
8289 gcc_assert (ar->end[n] == NULL);
8290 gcc_assert (ar->stride[n] == NULL);
8296 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
8297 newss->info->data.array.ref = ref;
8299 /* We add SS chains for all the subscripts in the section. */
8300 for (n = 0; n < ar->dimen; n++)
8304 switch (ar->dimen_type[n])
8307 /* Add SS for elemental (scalar) subscripts. */
8308 gcc_assert (ar->start[n]);
8309 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
8310 indexss->loop_chain = gfc_ss_terminator;
8311 newss->info->data.array.subscript[n] = indexss;
8315 /* We don't add anything for sections, just remember this
8316 dimension for later. */
8317 newss->dim[newss->dimen] = n;
8322 /* Create a GFC_SS_VECTOR index in which we can store
8323 the vector's descriptor. */
8324 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
8326 indexss->loop_chain = gfc_ss_terminator;
8327 newss->info->data.array.subscript[n] = indexss;
8328 newss->dim[newss->dimen] = n;
8333 /* We should know what sort of section it is by now. */
8337 /* We should have at least one non-elemental dimension,
8338 unless we are creating a descriptor for a (scalar) coarray. */
8339 gcc_assert (newss->dimen > 0
8340 || newss->info->data.array.ref->u.ar.as->corank > 0);
8345 /* We should know what sort of section it is by now. */
8354 /* Walk an expression operator. If only one operand of a binary expression is
8355 scalar, we must also add the scalar term to the SS chain. */
8358 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
8363 head = gfc_walk_subexpr (ss, expr->value.op.op1);
8364 if (expr->value.op.op2 == NULL)
8367 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
8369 /* All operands are scalar. Pass back and let the caller deal with it. */
8373 /* All operands require scalarization. */
8374 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
8377 /* One of the operands needs scalarization, the other is scalar.
8378 Create a gfc_ss for the scalar expression. */
8381 /* First operand is scalar. We build the chain in reverse order, so
8382 add the scalar SS after the second operand. */
8384 while (head && head->next != ss)
8386 /* Check we haven't somehow broken the chain. */
8388 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
8390 else /* head2 == head */
8392 gcc_assert (head2 == head);
8393 /* Second operand is scalar. */
8394 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
8401 /* Reverse a SS chain. */
8404 gfc_reverse_ss (gfc_ss * ss)
8409 gcc_assert (ss != NULL);
8411 head = gfc_ss_terminator;
8412 while (ss != gfc_ss_terminator)
8415 /* Check we didn't somehow break the chain. */
8416 gcc_assert (next != NULL);
8426 /* Given an expression refering to a procedure, return the symbol of its
8427 interface. We can't get the procedure symbol directly as we have to handle
8428 the case of (deferred) type-bound procedures. */
8431 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8436 if (procedure_ref == NULL)
8439 /* Normal procedure case. */
8440 sym = procedure_ref->symtree->n.sym;
8442 /* Typebound procedure case. */
8443 for (ref = procedure_ref->ref; ref; ref = ref->next)
8445 if (ref->type == REF_COMPONENT
8446 && ref->u.c.component->attr.proc_pointer)
8447 sym = ref->u.c.component->ts.interface;
8456 /* Walk the arguments of an elemental function.
8457 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8458 it is NULL, we don't do the check and the argument is assumed to be present.
8462 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8463 gfc_symbol *proc_ifc, gfc_ss_type type)
8465 gfc_formal_arglist *dummy_arg;
8471 head = gfc_ss_terminator;
8475 dummy_arg = proc_ifc->formal;
8480 for (; arg; arg = arg->next)
8482 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
8485 newss = gfc_walk_subexpr (head, arg->expr);
8488 /* Scalar argument. */
8489 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
8490 newss = gfc_get_scalar_ss (head, arg->expr);
8491 newss->info->type = type;
8493 if (dummy_arg != NULL
8494 && dummy_arg->sym->attr.optional
8495 && arg->expr->expr_type == EXPR_VARIABLE
8496 && (gfc_expr_attr (arg->expr).optional
8497 || gfc_expr_attr (arg->expr).allocatable
8498 || gfc_expr_attr (arg->expr).pointer))
8499 newss->info->data.scalar.can_be_null_ref = true;
8508 while (tail->next != gfc_ss_terminator)
8512 if (dummy_arg != NULL)
8513 dummy_arg = dummy_arg->next;
8518 /* If all the arguments are scalar we don't need the argument SS. */
8519 gfc_free_ss_chain (head);
8524 /* Add it onto the existing chain. */
8530 /* Walk a function call. Scalar functions are passed back, and taken out of
8531 scalarization loops. For elemental functions we walk their arguments.
8532 The result of functions returning arrays is stored in a temporary outside
8533 the loop, so that the function is only called once. Hence we do not need
8534 to walk their arguments. */
8537 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
8539 gfc_intrinsic_sym *isym;
8541 gfc_component *comp = NULL;
8543 isym = expr->value.function.isym;
8545 /* Handle intrinsic functions separately. */
8547 return gfc_walk_intrinsic_function (ss, expr, isym);
8549 sym = expr->value.function.esym;
8551 sym = expr->symtree->n.sym;
8553 /* A function that returns arrays. */
8554 gfc_is_proc_ptr_comp (expr, &comp);
8555 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
8556 || (comp && comp->attr.dimension))
8557 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
8559 /* Walk the parameters of an elemental function. For now we always pass
8561 if (sym->attr.elemental || (comp && comp->attr.elemental))
8562 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8563 gfc_get_proc_ifc_for_expr (expr),
8566 /* Scalar functions are OK as these are evaluated outside the scalarization
8567 loop. Pass back and let the caller deal with it. */
8572 /* An array temporary is constructed for array constructors. */
8575 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
8577 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
8581 /* Walk an expression. Add walked expressions to the head of the SS chain.
8582 A wholly scalar expression will not be added. */
8585 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
8589 switch (expr->expr_type)
8592 head = gfc_walk_variable_expr (ss, expr);
8596 head = gfc_walk_op_expr (ss, expr);
8600 head = gfc_walk_function_expr (ss, expr);
8605 case EXPR_STRUCTURE:
8606 /* Pass back and let the caller deal with it. */
8610 head = gfc_walk_array_constructor (ss, expr);
8613 case EXPR_SUBSTRING:
8614 /* Pass back and let the caller deal with it. */
8618 internal_error ("bad expression type during walk (%d)",
8625 /* Entry point for expression walking.
8626 A return value equal to the passed chain means this is
8627 a scalar expression. It is up to the caller to take whatever action is
8628 necessary to translate these. */
8631 gfc_walk_expr (gfc_expr * expr)
8635 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
8636 return gfc_reverse_ss (res);