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 outer_loop = outermost_loop (loop);
2410 /* TODO: This can generate bad code if there are ordering dependencies,
2411 e.g., a callee allocated function and an unknown size constructor. */
2412 gcc_assert (ss != NULL);
2414 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2418 /* Cross loop arrays are handled from within the most nested loop. */
2419 if (ss->nested_ss != NULL)
2423 expr = ss_info->expr;
2424 info = &ss_info->data.array;
2426 switch (ss_info->type)
2429 /* Scalar expression. Evaluate this now. This includes elemental
2430 dimension indices, but not array section bounds. */
2431 gfc_init_se (&se, NULL);
2432 gfc_conv_expr (&se, expr);
2433 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2435 if (expr->ts.type != BT_CHARACTER)
2437 /* Move the evaluation of scalar expressions outside the
2438 scalarization loop, except for WHERE assignments. */
2440 se.expr = convert(gfc_array_index_type, se.expr);
2441 if (!ss_info->where)
2442 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2443 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2446 gfc_add_block_to_block (&outer_loop->post, &se.post);
2448 ss_info->data.scalar.value = se.expr;
2449 ss_info->string_length = se.string_length;
2452 case GFC_SS_REFERENCE:
2453 /* Scalar argument to elemental procedure. */
2454 gfc_init_se (&se, NULL);
2455 if (ss_info->data.scalar.can_be_null_ref)
2457 /* If the actual argument can be absent (in other words, it can
2458 be a NULL reference), don't try to evaluate it; pass instead
2459 the reference directly. */
2460 gfc_conv_expr_reference (&se, expr);
2464 /* Otherwise, evaluate the argument outside the loop and pass
2465 a reference to the value. */
2466 gfc_conv_expr (&se, expr);
2468 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2469 gfc_add_block_to_block (&outer_loop->post, &se.post);
2470 if (gfc_is_class_scalar_expr (expr))
2471 /* This is necessary because the dynamic type will always be
2472 large than the declared type. In consequence, assigning
2473 the value to a temporary could segfault.
2474 OOP-TODO: see if this is generally correct or is the value
2475 has to be written to an allocated temporary, whose address
2476 is passed via ss_info. */
2477 ss_info->data.scalar.value = se.expr;
2479 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2482 ss_info->string_length = se.string_length;
2485 case GFC_SS_SECTION:
2486 /* Add the expressions for scalar and vector subscripts. */
2487 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2488 if (info->subscript[n])
2489 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2491 set_vector_loop_bounds (ss);
2495 /* Get the vector's descriptor and store it in SS. */
2496 gfc_init_se (&se, NULL);
2497 gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2498 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2499 gfc_add_block_to_block (&outer_loop->post, &se.post);
2500 info->descriptor = se.expr;
2503 case GFC_SS_INTRINSIC:
2504 gfc_add_intrinsic_ss_code (loop, ss);
2507 case GFC_SS_FUNCTION:
2508 /* Array function return value. We call the function and save its
2509 result in a temporary for use inside the loop. */
2510 gfc_init_se (&se, NULL);
2513 gfc_conv_expr (&se, expr);
2514 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2515 gfc_add_block_to_block (&outer_loop->post, &se.post);
2516 ss_info->string_length = se.string_length;
2519 case GFC_SS_CONSTRUCTOR:
2520 if (expr->ts.type == BT_CHARACTER
2521 && ss_info->string_length == NULL
2523 && expr->ts.u.cl->length)
2525 gfc_init_se (&se, NULL);
2526 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2527 gfc_charlen_type_node);
2528 ss_info->string_length = se.expr;
2529 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2530 gfc_add_block_to_block (&outer_loop->post, &se.post);
2532 trans_array_constructor (ss, where);
2536 case GFC_SS_COMPONENT:
2537 /* Do nothing. These are handled elsewhere. */
2546 for (nested_loop = loop->nested; nested_loop;
2547 nested_loop = nested_loop->next)
2548 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2552 /* Translate expressions for the descriptor and data pointer of a SS. */
2556 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2559 gfc_ss_info *ss_info;
2560 gfc_array_info *info;
2564 info = &ss_info->data.array;
2566 /* Get the descriptor for the array to be scalarized. */
2567 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2568 gfc_init_se (&se, NULL);
2569 se.descriptor_only = 1;
2570 gfc_conv_expr_lhs (&se, ss_info->expr);
2571 gfc_add_block_to_block (block, &se.pre);
2572 info->descriptor = se.expr;
2573 ss_info->string_length = se.string_length;
2577 /* Also the data pointer. */
2578 tmp = gfc_conv_array_data (se.expr);
2579 /* If this is a variable or address of a variable we use it directly.
2580 Otherwise we must evaluate it now to avoid breaking dependency
2581 analysis by pulling the expressions for elemental array indices
2584 || (TREE_CODE (tmp) == ADDR_EXPR
2585 && DECL_P (TREE_OPERAND (tmp, 0)))))
2586 tmp = gfc_evaluate_now (tmp, block);
2589 tmp = gfc_conv_array_offset (se.expr);
2590 info->offset = gfc_evaluate_now (tmp, block);
2592 /* Make absolutely sure that the saved_offset is indeed saved
2593 so that the variable is still accessible after the loops
2595 info->saved_offset = info->offset;
2600 /* Initialize a gfc_loopinfo structure. */
2603 gfc_init_loopinfo (gfc_loopinfo * loop)
2607 memset (loop, 0, sizeof (gfc_loopinfo));
2608 gfc_init_block (&loop->pre);
2609 gfc_init_block (&loop->post);
2611 /* Initially scalarize in order and default to no loop reversal. */
2612 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2615 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2618 loop->ss = gfc_ss_terminator;
2622 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2626 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2632 /* Return an expression for the data pointer of an array. */
2635 gfc_conv_array_data (tree descriptor)
2639 type = TREE_TYPE (descriptor);
2640 if (GFC_ARRAY_TYPE_P (type))
2642 if (TREE_CODE (type) == POINTER_TYPE)
2646 /* Descriptorless arrays. */
2647 return gfc_build_addr_expr (NULL_TREE, descriptor);
2651 return gfc_conv_descriptor_data_get (descriptor);
2655 /* Return an expression for the base offset of an array. */
2658 gfc_conv_array_offset (tree descriptor)
2662 type = TREE_TYPE (descriptor);
2663 if (GFC_ARRAY_TYPE_P (type))
2664 return GFC_TYPE_ARRAY_OFFSET (type);
2666 return gfc_conv_descriptor_offset_get (descriptor);
2670 /* Get an expression for the array stride. */
2673 gfc_conv_array_stride (tree descriptor, int dim)
2678 type = TREE_TYPE (descriptor);
2680 /* For descriptorless arrays use the array size. */
2681 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2682 if (tmp != NULL_TREE)
2685 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2690 /* Like gfc_conv_array_stride, but for the lower bound. */
2693 gfc_conv_array_lbound (tree descriptor, int dim)
2698 type = TREE_TYPE (descriptor);
2700 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2701 if (tmp != NULL_TREE)
2704 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2709 /* Like gfc_conv_array_stride, but for the upper bound. */
2712 gfc_conv_array_ubound (tree descriptor, int dim)
2717 type = TREE_TYPE (descriptor);
2719 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2720 if (tmp != NULL_TREE)
2723 /* This should only ever happen when passing an assumed shape array
2724 as an actual parameter. The value will never be used. */
2725 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2726 return gfc_index_zero_node;
2728 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2733 /* Generate code to perform an array index bound check. */
2736 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2737 locus * where, bool check_upper)
2740 tree tmp_lo, tmp_up;
2743 const char * name = NULL;
2745 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2748 descriptor = ss->info->data.array.descriptor;
2750 index = gfc_evaluate_now (index, &se->pre);
2752 /* We find a name for the error message. */
2753 name = ss->info->expr->symtree->n.sym->name;
2754 gcc_assert (name != NULL);
2756 if (TREE_CODE (descriptor) == VAR_DECL)
2757 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2759 /* If upper bound is present, include both bounds in the error message. */
2762 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2763 tmp_up = gfc_conv_array_ubound (descriptor, n);
2766 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2767 "outside of expected range (%%ld:%%ld)", n+1, name);
2769 asprintf (&msg, "Index '%%ld' of dimension %d "
2770 "outside of expected range (%%ld:%%ld)", n+1);
2772 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2774 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2775 fold_convert (long_integer_type_node, index),
2776 fold_convert (long_integer_type_node, tmp_lo),
2777 fold_convert (long_integer_type_node, tmp_up));
2778 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2780 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2781 fold_convert (long_integer_type_node, index),
2782 fold_convert (long_integer_type_node, tmp_lo),
2783 fold_convert (long_integer_type_node, tmp_up));
2788 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2791 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2792 "below lower bound of %%ld", n+1, name);
2794 asprintf (&msg, "Index '%%ld' of dimension %d "
2795 "below lower bound of %%ld", n+1);
2797 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2799 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2800 fold_convert (long_integer_type_node, index),
2801 fold_convert (long_integer_type_node, tmp_lo));
2809 /* Return the offset for an index. Performs bound checking for elemental
2810 dimensions. Single element references are processed separately.
2811 DIM is the array dimension, I is the loop dimension. */
2814 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2815 gfc_array_ref * ar, tree stride)
2817 gfc_array_info *info;
2822 info = &ss->info->data.array;
2824 /* Get the index into the array for this dimension. */
2827 gcc_assert (ar->type != AR_ELEMENT);
2828 switch (ar->dimen_type[dim])
2830 case DIMEN_THIS_IMAGE:
2834 /* Elemental dimension. */
2835 gcc_assert (info->subscript[dim]
2836 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2837 /* We've already translated this value outside the loop. */
2838 index = info->subscript[dim]->info->data.scalar.value;
2840 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2841 ar->as->type != AS_ASSUMED_SIZE
2842 || dim < ar->dimen - 1);
2846 gcc_assert (info && se->loop);
2847 gcc_assert (info->subscript[dim]
2848 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2849 desc = info->subscript[dim]->info->data.array.descriptor;
2851 /* Get a zero-based index into the vector. */
2852 index = fold_build2_loc (input_location, MINUS_EXPR,
2853 gfc_array_index_type,
2854 se->loop->loopvar[i], se->loop->from[i]);
2856 /* Multiply the index by the stride. */
2857 index = fold_build2_loc (input_location, MULT_EXPR,
2858 gfc_array_index_type,
2859 index, gfc_conv_array_stride (desc, 0));
2861 /* Read the vector to get an index into info->descriptor. */
2862 data = build_fold_indirect_ref_loc (input_location,
2863 gfc_conv_array_data (desc));
2864 index = gfc_build_array_ref (data, index, NULL);
2865 index = gfc_evaluate_now (index, &se->pre);
2866 index = fold_convert (gfc_array_index_type, index);
2868 /* Do any bounds checking on the final info->descriptor index. */
2869 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2870 ar->as->type != AS_ASSUMED_SIZE
2871 || dim < ar->dimen - 1);
2875 /* Scalarized dimension. */
2876 gcc_assert (info && se->loop);
2878 /* Multiply the loop variable by the stride and delta. */
2879 index = se->loop->loopvar[i];
2880 if (!integer_onep (info->stride[dim]))
2881 index = fold_build2_loc (input_location, MULT_EXPR,
2882 gfc_array_index_type, index,
2884 if (!integer_zerop (info->delta[dim]))
2885 index = fold_build2_loc (input_location, PLUS_EXPR,
2886 gfc_array_index_type, index,
2896 /* Temporary array or derived type component. */
2897 gcc_assert (se->loop);
2898 index = se->loop->loopvar[se->loop->order[i]];
2900 /* Pointer functions can have stride[0] different from unity.
2901 Use the stride returned by the function call and stored in
2902 the descriptor for the temporary. */
2903 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2904 && se->ss->info->expr
2905 && se->ss->info->expr->symtree
2906 && se->ss->info->expr->symtree->n.sym->result
2907 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2908 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2911 if (!integer_zerop (info->delta[dim]))
2912 index = fold_build2_loc (input_location, PLUS_EXPR,
2913 gfc_array_index_type, index, info->delta[dim]);
2916 /* Multiply by the stride. */
2917 if (!integer_onep (stride))
2918 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2925 /* Build a scalarized array reference using the vptr 'size'. */
2928 build_class_array_ref (gfc_se *se, tree base, tree index)
2935 gfc_expr *expr = se->ss->info->expr;
2940 if (expr == NULL || expr->ts.type != BT_CLASS)
2943 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
2944 ts = &expr->symtree->n.sym->ts;
2949 for (ref = expr->ref; ref; ref = ref->next)
2951 if (ref->type == REF_COMPONENT
2952 && ref->u.c.component->ts.type == BT_CLASS
2953 && ref->next && ref->next->type == REF_COMPONENT
2954 && strcmp (ref->next->u.c.component->name, "_data") == 0
2956 && ref->next->next->type == REF_ARRAY
2957 && ref->next->next->u.ar.type != AR_ELEMENT)
2959 ts = &ref->u.c.component->ts;
2968 if (class_ref == NULL)
2969 decl = expr->symtree->n.sym->backend_decl;
2972 /* Remove everything after the last class reference, convert the
2973 expression and then recover its tailend once more. */
2975 ref = class_ref->next;
2976 class_ref->next = NULL;
2977 gfc_init_se (&tmpse, NULL);
2978 gfc_conv_expr (&tmpse, expr);
2980 class_ref->next = ref;
2983 size = gfc_vtable_size_get (decl);
2985 /* Build the address of the element. */
2986 type = TREE_TYPE (TREE_TYPE (base));
2987 size = fold_convert (TREE_TYPE (index), size);
2988 offset = fold_build2_loc (input_location, MULT_EXPR,
2989 gfc_array_index_type,
2991 tmp = gfc_build_addr_expr (pvoid_type_node, base);
2992 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
2993 tmp = fold_convert (build_pointer_type (type), tmp);
2995 /* Return the element in the se expression. */
2996 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
3001 /* Build a scalarized reference to an array. */
3004 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3006 gfc_array_info *info;
3007 tree decl = NULL_TREE;
3015 expr = ss->info->expr;
3016 info = &ss->info->data.array;
3018 n = se->loop->order[0];
3022 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3023 /* Add the offset for this dimension to the stored offset for all other
3025 if (!integer_zerop (info->offset))
3026 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3027 index, info->offset);
3029 if (expr && is_subref_array (expr))
3030 decl = expr->symtree->n.sym->backend_decl;
3032 tmp = build_fold_indirect_ref_loc (input_location, info->data);
3034 /* Use the vptr 'size' field to access a class the element of a class
3036 if (build_class_array_ref (se, tmp, index))
3039 se->expr = gfc_build_array_ref (tmp, index, decl);
3043 /* Translate access of temporary array. */
3046 gfc_conv_tmp_array_ref (gfc_se * se)
3048 se->string_length = se->ss->info->string_length;
3049 gfc_conv_scalarized_array_ref (se, NULL);
3050 gfc_advance_se_ss_chain (se);
3053 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3056 add_to_offset (tree *cst_offset, tree *offset, tree t)
3058 if (TREE_CODE (t) == INTEGER_CST)
3059 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3062 if (!integer_zerop (*offset))
3063 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3064 gfc_array_index_type, *offset, t);
3070 /* Build an array reference. se->expr already holds the array descriptor.
3071 This should be either a variable, indirect variable reference or component
3072 reference. For arrays which do not have a descriptor, se->expr will be
3074 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3077 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
3081 tree offset, cst_offset;
3089 gcc_assert (ar->codimen);
3091 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3092 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3095 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3096 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3097 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3099 /* Use the actual tree type and not the wrapped coarray. */
3100 if (!se->want_pointer)
3101 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3108 /* Handle scalarized references separately. */
3109 if (ar->type != AR_ELEMENT)
3111 gfc_conv_scalarized_array_ref (se, ar);
3112 gfc_advance_se_ss_chain (se);
3116 cst_offset = offset = gfc_index_zero_node;
3117 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3119 /* Calculate the offsets from all the dimensions. Make sure to associate
3120 the final offset so that we form a chain of loop invariant summands. */
3121 for (n = ar->dimen - 1; n >= 0; n--)
3123 /* Calculate the index for this dimension. */
3124 gfc_init_se (&indexse, se);
3125 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3126 gfc_add_block_to_block (&se->pre, &indexse.pre);
3128 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3130 /* Check array bounds. */
3134 /* Evaluate the indexse.expr only once. */
3135 indexse.expr = save_expr (indexse.expr);
3138 tmp = gfc_conv_array_lbound (se->expr, n);
3139 if (sym->attr.temporary)
3141 gfc_init_se (&tmpse, se);
3142 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3143 gfc_array_index_type);
3144 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3148 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3150 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3151 "below lower bound of %%ld", n+1, sym->name);
3152 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3153 fold_convert (long_integer_type_node,
3155 fold_convert (long_integer_type_node, tmp));
3158 /* Upper bound, but not for the last dimension of assumed-size
3160 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3162 tmp = gfc_conv_array_ubound (se->expr, n);
3163 if (sym->attr.temporary)
3165 gfc_init_se (&tmpse, se);
3166 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3167 gfc_array_index_type);
3168 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3172 cond = fold_build2_loc (input_location, GT_EXPR,
3173 boolean_type_node, indexse.expr, tmp);
3174 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3175 "above upper bound of %%ld", n+1, sym->name);
3176 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3177 fold_convert (long_integer_type_node,
3179 fold_convert (long_integer_type_node, tmp));
3184 /* Multiply the index by the stride. */
3185 stride = gfc_conv_array_stride (se->expr, n);
3186 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3187 indexse.expr, stride);
3189 /* And add it to the total. */
3190 add_to_offset (&cst_offset, &offset, tmp);
3193 if (!integer_zerop (cst_offset))
3194 offset = fold_build2_loc (input_location, PLUS_EXPR,
3195 gfc_array_index_type, offset, cst_offset);
3197 /* Access the calculated element. */
3198 tmp = gfc_conv_array_data (se->expr);
3199 tmp = build_fold_indirect_ref (tmp);
3200 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
3204 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3205 LOOP_DIM dimension (if any) to array's offset. */
3208 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3209 gfc_array_ref *ar, int array_dim, int loop_dim)
3212 gfc_array_info *info;
3215 info = &ss->info->data.array;
3217 gfc_init_se (&se, NULL);
3219 se.expr = info->descriptor;
3220 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3221 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3222 gfc_add_block_to_block (pblock, &se.pre);
3224 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3225 gfc_array_index_type,
3226 info->offset, index);
3227 info->offset = gfc_evaluate_now (info->offset, pblock);
3231 /* Generate the code to be executed immediately before entering a
3232 scalarization loop. */
3235 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3236 stmtblock_t * pblock)
3239 gfc_ss_info *ss_info;
3240 gfc_array_info *info;
3241 gfc_ss_type ss_type;
3243 gfc_loopinfo *ploop;
3247 /* This code will be executed before entering the scalarization loop
3248 for this dimension. */
3249 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3253 if ((ss_info->useflags & flag) == 0)
3256 ss_type = ss_info->type;
3257 if (ss_type != GFC_SS_SECTION
3258 && ss_type != GFC_SS_FUNCTION
3259 && ss_type != GFC_SS_CONSTRUCTOR
3260 && ss_type != GFC_SS_COMPONENT)
3263 info = &ss_info->data.array;
3265 gcc_assert (dim < ss->dimen);
3266 gcc_assert (ss->dimen == loop->dimen);
3269 ar = &info->ref->u.ar;
3273 if (dim == loop->dimen - 1 && loop->parent != NULL)
3275 /* If we are in the outermost dimension of this loop, the previous
3276 dimension shall be in the parent loop. */
3277 gcc_assert (ss->parent != NULL);
3280 ploop = loop->parent;
3282 /* ss and ss->parent are about the same array. */
3283 gcc_assert (ss_info == pss->info);
3291 if (dim == loop->dimen - 1)
3296 /* For the time being, there is no loop reordering. */
3297 gcc_assert (i == ploop->order[i]);
3298 i = ploop->order[i];
3300 if (dim == loop->dimen - 1 && loop->parent == NULL)
3302 stride = gfc_conv_array_stride (info->descriptor,
3303 innermost_ss (ss)->dim[i]);
3305 /* Calculate the stride of the innermost loop. Hopefully this will
3306 allow the backend optimizers to do their stuff more effectively.
3308 info->stride0 = gfc_evaluate_now (stride, pblock);
3310 /* For the outermost loop calculate the offset due to any
3311 elemental dimensions. It will have been initialized with the
3312 base offset of the array. */
3315 for (i = 0; i < ar->dimen; i++)
3317 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3320 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3325 /* Add the offset for the previous loop dimension. */
3326 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3328 /* Remember this offset for the second loop. */
3329 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3330 info->saved_offset = info->offset;
3335 /* Start a scalarized expression. Creates a scope and declares loop
3339 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3345 gcc_assert (!loop->array_parameter);
3347 for (dim = loop->dimen - 1; dim >= 0; dim--)
3349 n = loop->order[dim];
3351 gfc_start_block (&loop->code[n]);
3353 /* Create the loop variable. */
3354 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3356 if (dim < loop->temp_dim)
3360 /* Calculate values that will be constant within this loop. */
3361 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3363 gfc_start_block (pbody);
3367 /* Generates the actual loop code for a scalarization loop. */
3370 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3371 stmtblock_t * pbody)
3382 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3383 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3384 && n == loop->dimen - 1)
3386 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3387 init = make_tree_vec (1);
3388 cond = make_tree_vec (1);
3389 incr = make_tree_vec (1);
3391 /* Cycle statement is implemented with a goto. Exit statement must not
3392 be present for this loop. */
3393 exit_label = gfc_build_label_decl (NULL_TREE);
3394 TREE_USED (exit_label) = 1;
3396 /* Label for cycle statements (if needed). */
3397 tmp = build1_v (LABEL_EXPR, exit_label);
3398 gfc_add_expr_to_block (pbody, tmp);
3400 stmt = make_node (OMP_FOR);
3402 TREE_TYPE (stmt) = void_type_node;
3403 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3405 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3406 OMP_CLAUSE_SCHEDULE);
3407 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3408 = OMP_CLAUSE_SCHEDULE_STATIC;
3409 if (ompws_flags & OMPWS_NOWAIT)
3410 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3411 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3413 /* Initialize the loopvar. */
3414 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3416 OMP_FOR_INIT (stmt) = init;
3417 /* The exit condition. */
3418 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3420 loop->loopvar[n], loop->to[n]);
3421 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3422 OMP_FOR_COND (stmt) = cond;
3423 /* Increment the loopvar. */
3424 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3425 loop->loopvar[n], gfc_index_one_node);
3426 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3427 void_type_node, loop->loopvar[n], tmp);
3428 OMP_FOR_INCR (stmt) = incr;
3430 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3431 gfc_add_expr_to_block (&loop->code[n], stmt);
3435 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3436 && (loop->temp_ss == NULL);
3438 loopbody = gfc_finish_block (pbody);
3442 tmp = loop->from[n];
3443 loop->from[n] = loop->to[n];
3447 /* Initialize the loopvar. */
3448 if (loop->loopvar[n] != loop->from[n])
3449 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3451 exit_label = gfc_build_label_decl (NULL_TREE);
3453 /* Generate the loop body. */
3454 gfc_init_block (&block);
3456 /* The exit condition. */
3457 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3458 boolean_type_node, loop->loopvar[n], loop->to[n]);
3459 tmp = build1_v (GOTO_EXPR, exit_label);
3460 TREE_USED (exit_label) = 1;
3461 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3462 gfc_add_expr_to_block (&block, tmp);
3464 /* The main body. */
3465 gfc_add_expr_to_block (&block, loopbody);
3467 /* Increment the loopvar. */
3468 tmp = fold_build2_loc (input_location,
3469 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3470 gfc_array_index_type, loop->loopvar[n],
3471 gfc_index_one_node);
3473 gfc_add_modify (&block, loop->loopvar[n], tmp);
3475 /* Build the loop. */
3476 tmp = gfc_finish_block (&block);
3477 tmp = build1_v (LOOP_EXPR, tmp);
3478 gfc_add_expr_to_block (&loop->code[n], tmp);
3480 /* Add the exit label. */
3481 tmp = build1_v (LABEL_EXPR, exit_label);
3482 gfc_add_expr_to_block (&loop->code[n], tmp);
3488 /* Finishes and generates the loops for a scalarized expression. */
3491 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3496 stmtblock_t *pblock;
3500 /* Generate the loops. */
3501 for (dim = 0; dim < loop->dimen; dim++)
3503 n = loop->order[dim];
3504 gfc_trans_scalarized_loop_end (loop, n, pblock);
3505 loop->loopvar[n] = NULL_TREE;
3506 pblock = &loop->code[n];
3509 tmp = gfc_finish_block (pblock);
3510 gfc_add_expr_to_block (&loop->pre, tmp);
3512 /* Clear all the used flags. */
3513 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3514 if (ss->parent == NULL)
3515 ss->info->useflags = 0;
3519 /* Finish the main body of a scalarized expression, and start the secondary
3523 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3527 stmtblock_t *pblock;
3531 /* We finish as many loops as are used by the temporary. */
3532 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3534 n = loop->order[dim];
3535 gfc_trans_scalarized_loop_end (loop, n, pblock);
3536 loop->loopvar[n] = NULL_TREE;
3537 pblock = &loop->code[n];
3540 /* We don't want to finish the outermost loop entirely. */
3541 n = loop->order[loop->temp_dim - 1];
3542 gfc_trans_scalarized_loop_end (loop, n, pblock);
3544 /* Restore the initial offsets. */
3545 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3547 gfc_ss_type ss_type;
3548 gfc_ss_info *ss_info;
3552 if ((ss_info->useflags & 2) == 0)
3555 ss_type = ss_info->type;
3556 if (ss_type != GFC_SS_SECTION
3557 && ss_type != GFC_SS_FUNCTION
3558 && ss_type != GFC_SS_CONSTRUCTOR
3559 && ss_type != GFC_SS_COMPONENT)
3562 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3565 /* Restart all the inner loops we just finished. */
3566 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3568 n = loop->order[dim];
3570 gfc_start_block (&loop->code[n]);
3572 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3574 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3577 /* Start a block for the secondary copying code. */
3578 gfc_start_block (body);
3582 /* Precalculate (either lower or upper) bound of an array section.
3583 BLOCK: Block in which the (pre)calculation code will go.
3584 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3585 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3586 DESC: Array descriptor from which the bound will be picked if unspecified
3587 (either lower or upper bound according to LBOUND). */
3590 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3591 tree desc, int dim, bool lbound)
3594 gfc_expr * input_val = values[dim];
3595 tree *output = &bounds[dim];
3600 /* Specified section bound. */
3601 gfc_init_se (&se, NULL);
3602 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3603 gfc_add_block_to_block (block, &se.pre);
3608 /* No specific bound specified so use the bound of the array. */
3609 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3610 gfc_conv_array_ubound (desc, dim);
3612 *output = gfc_evaluate_now (*output, block);
3616 /* Calculate the lower bound of an array section. */
3619 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3621 gfc_expr *stride = NULL;
3624 gfc_array_info *info;
3627 gcc_assert (ss->info->type == GFC_SS_SECTION);
3629 info = &ss->info->data.array;
3630 ar = &info->ref->u.ar;
3632 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3634 /* We use a zero-based index to access the vector. */
3635 info->start[dim] = gfc_index_zero_node;
3636 info->end[dim] = NULL;
3637 info->stride[dim] = gfc_index_one_node;
3641 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3642 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3643 desc = info->descriptor;
3644 stride = ar->stride[dim];
3646 /* Calculate the start of the range. For vector subscripts this will
3647 be the range of the vector. */
3648 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3650 /* Similarly calculate the end. Although this is not used in the
3651 scalarizer, it is needed when checking bounds and where the end
3652 is an expression with side-effects. */
3653 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3655 /* Calculate the stride. */
3657 info->stride[dim] = gfc_index_one_node;
3660 gfc_init_se (&se, NULL);
3661 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3662 gfc_add_block_to_block (&loop->pre, &se.pre);
3663 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3668 /* Calculates the range start and stride for a SS chain. Also gets the
3669 descriptor and data pointer. The range of vector subscripts is the size
3670 of the vector. Array bounds are also checked. */
3673 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3681 /* Determine the rank of the loop. */
3682 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3684 switch (ss->info->type)
3686 case GFC_SS_SECTION:
3687 case GFC_SS_CONSTRUCTOR:
3688 case GFC_SS_FUNCTION:
3689 case GFC_SS_COMPONENT:
3690 loop->dimen = ss->dimen;
3693 /* As usual, lbound and ubound are exceptions!. */
3694 case GFC_SS_INTRINSIC:
3695 switch (ss->info->expr->value.function.isym->id)
3697 case GFC_ISYM_LBOUND:
3698 case GFC_ISYM_UBOUND:
3699 case GFC_ISYM_LCOBOUND:
3700 case GFC_ISYM_UCOBOUND:
3701 case GFC_ISYM_THIS_IMAGE:
3702 loop->dimen = ss->dimen;
3714 /* We should have determined the rank of the expression by now. If
3715 not, that's bad news. */
3719 /* Loop over all the SS in the chain. */
3720 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3722 gfc_ss_info *ss_info;
3723 gfc_array_info *info;
3727 expr = ss_info->expr;
3728 info = &ss_info->data.array;
3730 if (expr && expr->shape && !info->shape)
3731 info->shape = expr->shape;
3733 switch (ss_info->type)
3735 case GFC_SS_SECTION:
3736 /* Get the descriptor for the array. If it is a cross loops array,
3737 we got the descriptor already in the outermost loop. */
3738 if (ss->parent == NULL)
3739 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3741 for (n = 0; n < ss->dimen; n++)
3742 gfc_conv_section_startstride (loop, ss, ss->dim[n]);
3745 case GFC_SS_INTRINSIC:
3746 switch (expr->value.function.isym->id)
3748 /* Fall through to supply start and stride. */
3749 case GFC_ISYM_LBOUND:
3750 case GFC_ISYM_UBOUND:
3751 case GFC_ISYM_LCOBOUND:
3752 case GFC_ISYM_UCOBOUND:
3753 case GFC_ISYM_THIS_IMAGE:
3760 case GFC_SS_CONSTRUCTOR:
3761 case GFC_SS_FUNCTION:
3762 for (n = 0; n < ss->dimen; n++)
3764 int dim = ss->dim[n];
3766 info->start[dim] = gfc_index_zero_node;
3767 info->end[dim] = gfc_index_zero_node;
3768 info->stride[dim] = gfc_index_one_node;
3777 /* The rest is just runtime bound checking. */
3778 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3781 tree lbound, ubound;
3783 tree size[GFC_MAX_DIMENSIONS];
3784 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3785 gfc_array_info *info;
3789 gfc_start_block (&block);
3791 for (n = 0; n < loop->dimen; n++)
3792 size[n] = NULL_TREE;
3794 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3797 gfc_ss_info *ss_info;
3800 const char *expr_name;
3803 if (ss_info->type != GFC_SS_SECTION)
3806 /* Catch allocatable lhs in f2003. */
3807 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3810 expr = ss_info->expr;
3811 expr_loc = &expr->where;
3812 expr_name = expr->symtree->name;
3814 gfc_start_block (&inner);
3816 /* TODO: range checking for mapped dimensions. */
3817 info = &ss_info->data.array;
3819 /* This code only checks ranges. Elemental and vector
3820 dimensions are checked later. */
3821 for (n = 0; n < loop->dimen; n++)
3826 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3829 if (dim == info->ref->u.ar.dimen - 1
3830 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3831 check_upper = false;
3835 /* Zero stride is not allowed. */
3836 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3837 info->stride[dim], gfc_index_zero_node);
3838 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3839 "of array '%s'", dim + 1, expr_name);
3840 gfc_trans_runtime_check (true, false, tmp, &inner,
3844 desc = info->descriptor;
3846 /* This is the run-time equivalent of resolve.c's
3847 check_dimension(). The logical is more readable there
3848 than it is here, with all the trees. */
3849 lbound = gfc_conv_array_lbound (desc, dim);
3850 end = info->end[dim];
3852 ubound = gfc_conv_array_ubound (desc, dim);
3856 /* non_zerosized is true when the selected range is not
3858 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3859 boolean_type_node, info->stride[dim],
3860 gfc_index_zero_node);
3861 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3862 info->start[dim], end);
3863 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3864 boolean_type_node, stride_pos, tmp);
3866 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3868 info->stride[dim], gfc_index_zero_node);
3869 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3870 info->start[dim], end);
3871 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3874 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3876 stride_pos, stride_neg);
3878 /* Check the start of the range against the lower and upper
3879 bounds of the array, if the range is not empty.
3880 If upper bound is present, include both bounds in the
3884 tmp = fold_build2_loc (input_location, LT_EXPR,
3886 info->start[dim], lbound);
3887 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3889 non_zerosized, tmp);
3890 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3892 info->start[dim], ubound);
3893 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3895 non_zerosized, tmp2);
3896 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3897 "outside of expected range (%%ld:%%ld)",
3898 dim + 1, expr_name);
3899 gfc_trans_runtime_check (true, false, tmp, &inner,
3901 fold_convert (long_integer_type_node, info->start[dim]),
3902 fold_convert (long_integer_type_node, lbound),
3903 fold_convert (long_integer_type_node, ubound));
3904 gfc_trans_runtime_check (true, false, tmp2, &inner,
3906 fold_convert (long_integer_type_node, info->start[dim]),
3907 fold_convert (long_integer_type_node, lbound),
3908 fold_convert (long_integer_type_node, ubound));
3913 tmp = fold_build2_loc (input_location, LT_EXPR,
3915 info->start[dim], lbound);
3916 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3917 boolean_type_node, non_zerosized, tmp);
3918 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3919 "below lower bound of %%ld",
3920 dim + 1, expr_name);
3921 gfc_trans_runtime_check (true, false, tmp, &inner,
3923 fold_convert (long_integer_type_node, info->start[dim]),
3924 fold_convert (long_integer_type_node, lbound));
3928 /* Compute the last element of the range, which is not
3929 necessarily "end" (think 0:5:3, which doesn't contain 5)
3930 and check it against both lower and upper bounds. */
3932 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3933 gfc_array_index_type, end,
3935 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3936 gfc_array_index_type, tmp,
3938 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3939 gfc_array_index_type, end, tmp);
3940 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3941 boolean_type_node, tmp, lbound);
3942 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3943 boolean_type_node, non_zerosized, tmp2);
3946 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3947 boolean_type_node, tmp, ubound);
3948 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3949 boolean_type_node, non_zerosized, tmp3);
3950 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3951 "outside of expected range (%%ld:%%ld)",
3952 dim + 1, expr_name);
3953 gfc_trans_runtime_check (true, false, tmp2, &inner,
3955 fold_convert (long_integer_type_node, tmp),
3956 fold_convert (long_integer_type_node, ubound),
3957 fold_convert (long_integer_type_node, lbound));
3958 gfc_trans_runtime_check (true, false, tmp3, &inner,
3960 fold_convert (long_integer_type_node, tmp),
3961 fold_convert (long_integer_type_node, ubound),
3962 fold_convert (long_integer_type_node, lbound));
3967 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3968 "below lower bound of %%ld",
3969 dim + 1, expr_name);
3970 gfc_trans_runtime_check (true, false, tmp2, &inner,
3972 fold_convert (long_integer_type_node, tmp),
3973 fold_convert (long_integer_type_node, lbound));
3977 /* Check the section sizes match. */
3978 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3979 gfc_array_index_type, end,
3981 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3982 gfc_array_index_type, tmp,
3984 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3985 gfc_array_index_type,
3986 gfc_index_one_node, tmp);
3987 tmp = fold_build2_loc (input_location, MAX_EXPR,
3988 gfc_array_index_type, tmp,
3989 build_int_cst (gfc_array_index_type, 0));
3990 /* We remember the size of the first section, and check all the
3991 others against this. */
3994 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3995 boolean_type_node, tmp, size[n]);
3996 asprintf (&msg, "Array bound mismatch for dimension %d "
3997 "of array '%s' (%%ld/%%ld)",
3998 dim + 1, expr_name);
4000 gfc_trans_runtime_check (true, false, tmp3, &inner,
4002 fold_convert (long_integer_type_node, tmp),
4003 fold_convert (long_integer_type_node, size[n]));
4008 size[n] = gfc_evaluate_now (tmp, &inner);
4011 tmp = gfc_finish_block (&inner);
4013 /* For optional arguments, only check bounds if the argument is
4015 if (expr->symtree->n.sym->attr.optional
4016 || expr->symtree->n.sym->attr.not_always_present)
4017 tmp = build3_v (COND_EXPR,
4018 gfc_conv_expr_present (expr->symtree->n.sym),
4019 tmp, build_empty_stmt (input_location));
4021 gfc_add_expr_to_block (&block, tmp);
4025 tmp = gfc_finish_block (&block);
4026 gfc_add_expr_to_block (&loop->pre, tmp);
4029 for (loop = loop->nested; loop; loop = loop->next)
4030 gfc_conv_ss_startstride (loop);
4033 /* Return true if both symbols could refer to the same data object. Does
4034 not take account of aliasing due to equivalence statements. */
4037 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4038 bool lsym_target, bool rsym_pointer, bool rsym_target)
4040 /* Aliasing isn't possible if the symbols have different base types. */
4041 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4044 /* Pointers can point to other pointers and target objects. */
4046 if ((lsym_pointer && (rsym_pointer || rsym_target))
4047 || (rsym_pointer && (lsym_pointer || lsym_target)))
4050 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4051 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4053 if (lsym_target && rsym_target
4054 && ((lsym->attr.dummy && !lsym->attr.contiguous
4055 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4056 || (rsym->attr.dummy && !rsym->attr.contiguous
4057 && (!rsym->attr.dimension
4058 || rsym->as->type == AS_ASSUMED_SHAPE))))
4065 /* Return true if the two SS could be aliased, i.e. both point to the same data
4067 /* TODO: resolve aliases based on frontend expressions. */
4070 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4074 gfc_expr *lexpr, *rexpr;
4077 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4079 lexpr = lss->info->expr;
4080 rexpr = rss->info->expr;
4082 lsym = lexpr->symtree->n.sym;
4083 rsym = rexpr->symtree->n.sym;
4085 lsym_pointer = lsym->attr.pointer;
4086 lsym_target = lsym->attr.target;
4087 rsym_pointer = rsym->attr.pointer;
4088 rsym_target = rsym->attr.target;
4090 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4091 rsym_pointer, rsym_target))
4094 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4095 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4098 /* For derived types we must check all the component types. We can ignore
4099 array references as these will have the same base type as the previous
4101 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4103 if (lref->type != REF_COMPONENT)
4106 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4107 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4109 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4110 rsym_pointer, rsym_target))
4113 if ((lsym_pointer && (rsym_pointer || rsym_target))
4114 || (rsym_pointer && (lsym_pointer || lsym_target)))
4116 if (gfc_compare_types (&lref->u.c.component->ts,
4121 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4124 if (rref->type != REF_COMPONENT)
4127 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4128 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4130 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4131 lsym_pointer, lsym_target,
4132 rsym_pointer, rsym_target))
4135 if ((lsym_pointer && (rsym_pointer || rsym_target))
4136 || (rsym_pointer && (lsym_pointer || lsym_target)))
4138 if (gfc_compare_types (&lref->u.c.component->ts,
4139 &rref->u.c.sym->ts))
4141 if (gfc_compare_types (&lref->u.c.sym->ts,
4142 &rref->u.c.component->ts))
4144 if (gfc_compare_types (&lref->u.c.component->ts,
4145 &rref->u.c.component->ts))
4151 lsym_pointer = lsym->attr.pointer;
4152 lsym_target = lsym->attr.target;
4153 lsym_pointer = lsym->attr.pointer;
4154 lsym_target = lsym->attr.target;
4156 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4158 if (rref->type != REF_COMPONENT)
4161 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4162 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4164 if (symbols_could_alias (rref->u.c.sym, lsym,
4165 lsym_pointer, lsym_target,
4166 rsym_pointer, rsym_target))
4169 if ((lsym_pointer && (rsym_pointer || rsym_target))
4170 || (rsym_pointer && (lsym_pointer || lsym_target)))
4172 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4181 /* Resolve array data dependencies. Creates a temporary if required. */
4182 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4186 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4192 gfc_expr *dest_expr;
4197 loop->temp_ss = NULL;
4198 dest_expr = dest->info->expr;
4200 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4202 if (ss->info->type != GFC_SS_SECTION)
4205 ss_expr = ss->info->expr;
4207 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4209 if (gfc_could_be_alias (dest, ss)
4210 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4218 lref = dest_expr->ref;
4219 rref = ss_expr->ref;
4221 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4226 for (i = 0; i < dest->dimen; i++)
4227 for (j = 0; j < ss->dimen; j++)
4229 && dest->dim[i] == ss->dim[j])
4231 /* If we don't access array elements in the same order,
4232 there is a dependency. */
4237 /* TODO : loop shifting. */
4240 /* Mark the dimensions for LOOP SHIFTING */
4241 for (n = 0; n < loop->dimen; n++)
4243 int dim = dest->data.info.dim[n];
4245 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4247 else if (! gfc_is_same_range (&lref->u.ar,
4248 &rref->u.ar, dim, 0))
4252 /* Put all the dimensions with dependencies in the
4255 for (n = 0; n < loop->dimen; n++)
4257 gcc_assert (loop->order[n] == n);
4259 loop->order[dim++] = n;
4261 for (n = 0; n < loop->dimen; n++)
4264 loop->order[dim++] = n;
4267 gcc_assert (dim == loop->dimen);
4278 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4279 if (GFC_ARRAY_TYPE_P (base_type)
4280 || GFC_DESCRIPTOR_TYPE_P (base_type))
4281 base_type = gfc_get_element_type (base_type);
4282 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4284 gfc_add_ss_to_loop (loop, loop->temp_ss);
4287 loop->temp_ss = NULL;
4291 /* Browse through each array's information from the scalarizer and set the loop
4292 bounds according to the "best" one (per dimension), i.e. the one which
4293 provides the most information (constant bounds, shape, etc). */
4296 set_loop_bounds (gfc_loopinfo *loop)
4298 int n, dim, spec_dim;
4299 gfc_array_info *info;
4300 gfc_array_info *specinfo;
4304 bool dynamic[GFC_MAX_DIMENSIONS];
4308 loopspec = loop->specloop;
4311 for (n = 0; n < loop->dimen; n++)
4315 /* We use one SS term, and use that to determine the bounds of the
4316 loop for this dimension. We try to pick the simplest term. */
4317 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4319 gfc_ss_type ss_type;
4321 ss_type = ss->info->type;
4322 if (ss_type == GFC_SS_SCALAR
4323 || ss_type == GFC_SS_TEMP
4324 || ss_type == GFC_SS_REFERENCE)
4327 info = &ss->info->data.array;
4330 if (loopspec[n] != NULL)
4332 specinfo = &loopspec[n]->info->data.array;
4333 spec_dim = loopspec[n]->dim[n];
4337 /* Silence unitialized warnings. */
4344 gcc_assert (info->shape[dim]);
4345 /* The frontend has worked out the size for us. */
4348 || !integer_zerop (specinfo->start[spec_dim]))
4349 /* Prefer zero-based descriptors if possible. */
4354 if (ss_type == GFC_SS_CONSTRUCTOR)
4356 gfc_constructor_base base;
4357 /* An unknown size constructor will always be rank one.
4358 Higher rank constructors will either have known shape,
4359 or still be wrapped in a call to reshape. */
4360 gcc_assert (loop->dimen == 1);
4362 /* Always prefer to use the constructor bounds if the size
4363 can be determined at compile time. Prefer not to otherwise,
4364 since the general case involves realloc, and it's better to
4365 avoid that overhead if possible. */
4366 base = ss->info->expr->value.constructor;
4367 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4368 if (!dynamic[n] || !loopspec[n])
4373 /* TODO: Pick the best bound if we have a choice between a
4374 function and something else. */
4375 if (ss_type == GFC_SS_FUNCTION)
4381 /* Avoid using an allocatable lhs in an assignment, since
4382 there might be a reallocation coming. */
4383 if (loopspec[n] && ss->is_alloc_lhs)
4386 if (ss_type != GFC_SS_SECTION)
4391 /* Criteria for choosing a loop specifier (most important first):
4392 doesn't need realloc
4398 else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4399 || n >= loop->dimen)
4401 else if (integer_onep (info->stride[dim])
4402 && !integer_onep (specinfo->stride[spec_dim]))
4404 else if (INTEGER_CST_P (info->stride[dim])
4405 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4407 else if (INTEGER_CST_P (info->start[dim])
4408 && !INTEGER_CST_P (specinfo->start[spec_dim]))
4410 /* We don't work out the upper bound.
4411 else if (INTEGER_CST_P (info->finish[n])
4412 && ! INTEGER_CST_P (specinfo->finish[n]))
4413 loopspec[n] = ss; */
4416 /* We should have found the scalarization loop specifier. If not,
4418 gcc_assert (loopspec[n]);
4420 info = &loopspec[n]->info->data.array;
4421 dim = loopspec[n]->dim[n];
4423 /* Set the extents of this range. */
4424 cshape = info->shape;
4425 if (cshape && INTEGER_CST_P (info->start[dim])
4426 && INTEGER_CST_P (info->stride[dim]))
4428 loop->from[n] = info->start[dim];
4429 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
4430 mpz_sub_ui (i, i, 1);
4431 /* To = from + (size - 1) * stride. */
4432 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4433 if (!integer_onep (info->stride[dim]))
4434 tmp = fold_build2_loc (input_location, MULT_EXPR,
4435 gfc_array_index_type, tmp,
4437 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4438 gfc_array_index_type,
4439 loop->from[n], tmp);
4443 loop->from[n] = info->start[dim];
4444 switch (loopspec[n]->info->type)
4446 case GFC_SS_CONSTRUCTOR:
4447 /* The upper bound is calculated when we expand the
4449 gcc_assert (loop->to[n] == NULL_TREE);
4452 case GFC_SS_SECTION:
4453 /* Use the end expression if it exists and is not constant,
4454 so that it is only evaluated once. */
4455 loop->to[n] = info->end[dim];
4458 case GFC_SS_FUNCTION:
4459 /* The loop bound will be set when we generate the call. */
4460 gcc_assert (loop->to[n] == NULL_TREE);
4468 /* Transform everything so we have a simple incrementing variable. */
4469 if (integer_onep (info->stride[dim]))
4470 info->delta[dim] = gfc_index_zero_node;
4473 /* Set the delta for this section. */
4474 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4475 /* Number of iterations is (end - start + step) / step.
4476 with start = 0, this simplifies to
4478 for (i = 0; i<=last; i++){...}; */
4479 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4480 gfc_array_index_type, loop->to[n],
4482 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4483 gfc_array_index_type, tmp, info->stride[dim]);
4484 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4485 tmp, build_int_cst (gfc_array_index_type, -1));
4486 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4487 /* Make the loop variable start at 0. */
4488 loop->from[n] = gfc_index_zero_node;
4493 for (loop = loop->nested; loop; loop = loop->next)
4494 set_loop_bounds (loop);
4498 /* Initialize the scalarization loop. Creates the loop variables. Determines
4499 the range of the loop variables. Creates a temporary if required.
4500 Also generates code for scalar expressions which have been
4501 moved outside the loop. */
4504 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4509 set_loop_bounds (loop);
4511 /* Add all the scalar code that can be taken out of the loops.
4512 This may include calculating the loop bounds, so do it before
4513 allocating the temporary. */
4514 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4516 tmp_ss = loop->temp_ss;
4517 /* If we want a temporary then create it. */
4520 gfc_ss_info *tmp_ss_info;
4522 tmp_ss_info = tmp_ss->info;
4523 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4524 gcc_assert (loop->parent == NULL);
4526 /* Make absolutely sure that this is a complete type. */
4527 if (tmp_ss_info->string_length)
4528 tmp_ss_info->data.temp.type
4529 = gfc_get_character_type_len_for_eltype
4530 (TREE_TYPE (tmp_ss_info->data.temp.type),
4531 tmp_ss_info->string_length);
4533 tmp = tmp_ss_info->data.temp.type;
4534 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4535 tmp_ss_info->type = GFC_SS_SECTION;
4537 gcc_assert (tmp_ss->dimen != 0);
4539 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4540 NULL_TREE, false, true, false, where);
4543 /* For array parameters we don't have loop variables, so don't calculate the
4545 if (!loop->array_parameter)
4546 gfc_set_delta (loop);
4550 /* Calculates how to transform from loop variables to array indices for each
4551 array: once loop bounds are chosen, sets the difference (DELTA field) between
4552 loop bounds and array reference bounds, for each array info. */
4555 gfc_set_delta (gfc_loopinfo *loop)
4557 gfc_ss *ss, **loopspec;
4558 gfc_array_info *info;
4562 loopspec = loop->specloop;
4564 /* Calculate the translation from loop variables to array indices. */
4565 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4567 gfc_ss_type ss_type;
4569 ss_type = ss->info->type;
4570 if (ss_type != GFC_SS_SECTION
4571 && ss_type != GFC_SS_COMPONENT
4572 && ss_type != GFC_SS_CONSTRUCTOR)
4575 info = &ss->info->data.array;
4577 for (n = 0; n < ss->dimen; n++)
4579 /* If we are specifying the range the delta is already set. */
4580 if (loopspec[n] != ss)
4584 /* Calculate the offset relative to the loop variable.
4585 First multiply by the stride. */
4586 tmp = loop->from[n];
4587 if (!integer_onep (info->stride[dim]))
4588 tmp = fold_build2_loc (input_location, MULT_EXPR,
4589 gfc_array_index_type,
4590 tmp, info->stride[dim]);
4592 /* Then subtract this from our starting value. */
4593 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4594 gfc_array_index_type,
4595 info->start[dim], tmp);
4597 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4602 for (loop = loop->nested; loop; loop = loop->next)
4603 gfc_set_delta (loop);
4607 /* Calculate the size of a given array dimension from the bounds. This
4608 is simply (ubound - lbound + 1) if this expression is positive
4609 or 0 if it is negative (pick either one if it is zero). Optionally
4610 (if or_expr is present) OR the (expression != 0) condition to it. */
4613 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4618 /* Calculate (ubound - lbound + 1). */
4619 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4621 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4622 gfc_index_one_node);
4624 /* Check whether the size for this dimension is negative. */
4625 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4626 gfc_index_zero_node);
4627 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4628 gfc_index_zero_node, res);
4630 /* Build OR expression. */
4632 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4633 boolean_type_node, *or_expr, cond);
4639 /* For an array descriptor, get the total number of elements. This is just
4640 the product of the extents along from_dim to to_dim. */
4643 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4648 res = gfc_index_one_node;
4650 for (dim = from_dim; dim < to_dim; ++dim)
4656 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4657 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4659 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4660 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4668 /* Full size of an array. */
4671 gfc_conv_descriptor_size (tree desc, int rank)
4673 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4677 /* Size of a coarray for all dimensions but the last. */
4680 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4682 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4686 /* Fills in an array descriptor, and returns the size of the array.
4687 The size will be a simple_val, ie a variable or a constant. Also
4688 calculates the offset of the base. The pointer argument overflow,
4689 which should be of integer type, will increase in value if overflow
4690 occurs during the size calculation. Returns the size of the array.
4694 for (n = 0; n < rank; n++)
4696 a.lbound[n] = specified_lower_bound;
4697 offset = offset + a.lbond[n] * stride;
4699 a.ubound[n] = specified_upper_bound;
4700 a.stride[n] = stride;
4701 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4702 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4703 stride = stride * size;
4705 for (n = rank; n < rank+corank; n++)
4706 (Set lcobound/ucobound as above.)
4707 element_size = sizeof (array element);
4710 stride = (size_t) stride;
4711 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4712 stride = stride * element_size;
4718 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4719 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4720 stmtblock_t * descriptor_block, tree * overflow,
4721 tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
4734 stmtblock_t thenblock;
4735 stmtblock_t elseblock;
4740 type = TREE_TYPE (descriptor);
4742 stride = gfc_index_one_node;
4743 offset = gfc_index_zero_node;
4745 /* Set the dtype. */
4746 tmp = gfc_conv_descriptor_dtype (descriptor);
4747 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4749 or_expr = boolean_false_node;
4751 for (n = 0; n < rank; n++)
4756 /* We have 3 possibilities for determining the size of the array:
4757 lower == NULL => lbound = 1, ubound = upper[n]
4758 upper[n] = NULL => lbound = 1, ubound = lower[n]
4759 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4762 /* Set lower bound. */
4763 gfc_init_se (&se, NULL);
4765 se.expr = gfc_index_one_node;
4768 gcc_assert (lower[n]);
4771 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4772 gfc_add_block_to_block (pblock, &se.pre);
4776 se.expr = gfc_index_one_node;
4780 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4781 gfc_rank_cst[n], se.expr);
4782 conv_lbound = se.expr;
4784 /* Work out the offset for this component. */
4785 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4787 offset = fold_build2_loc (input_location, MINUS_EXPR,
4788 gfc_array_index_type, offset, tmp);
4790 /* Set upper bound. */
4791 gfc_init_se (&se, NULL);
4792 gcc_assert (ubound);
4793 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4794 gfc_add_block_to_block (pblock, &se.pre);
4796 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4797 gfc_rank_cst[n], se.expr);
4798 conv_ubound = se.expr;
4800 /* Store the stride. */
4801 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4802 gfc_rank_cst[n], stride);
4804 /* Calculate size and check whether extent is negative. */
4805 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4806 size = gfc_evaluate_now (size, pblock);
4808 /* Check whether multiplying the stride by the number of
4809 elements in this dimension would overflow. We must also check
4810 whether the current dimension has zero size in order to avoid
4813 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4814 gfc_array_index_type,
4815 fold_convert (gfc_array_index_type,
4816 TYPE_MAX_VALUE (gfc_array_index_type)),
4818 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4819 boolean_type_node, tmp, stride));
4820 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4821 integer_one_node, integer_zero_node);
4822 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4823 boolean_type_node, size,
4824 gfc_index_zero_node));
4825 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4826 integer_zero_node, tmp);
4827 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4829 *overflow = gfc_evaluate_now (tmp, pblock);
4831 /* Multiply the stride by the number of elements in this dimension. */
4832 stride = fold_build2_loc (input_location, MULT_EXPR,
4833 gfc_array_index_type, stride, size);
4834 stride = gfc_evaluate_now (stride, pblock);
4837 for (n = rank; n < rank + corank; n++)
4841 /* Set lower bound. */
4842 gfc_init_se (&se, NULL);
4843 if (lower == NULL || lower[n] == NULL)
4845 gcc_assert (n == rank + corank - 1);
4846 se.expr = gfc_index_one_node;
4850 if (ubound || n == rank + corank - 1)
4852 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4853 gfc_add_block_to_block (pblock, &se.pre);
4857 se.expr = gfc_index_one_node;
4861 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4862 gfc_rank_cst[n], se.expr);
4864 if (n < rank + corank - 1)
4866 gfc_init_se (&se, NULL);
4867 gcc_assert (ubound);
4868 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4869 gfc_add_block_to_block (pblock, &se.pre);
4870 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4871 gfc_rank_cst[n], se.expr);
4875 /* The stride is the number of elements in the array, so multiply by the
4876 size of an element to get the total size. Obviously, if there ia a
4877 SOURCE expression (expr3) we must use its element size. */
4878 if (expr3_elem_size != NULL_TREE)
4879 tmp = expr3_elem_size;
4880 else if (expr3 != NULL)
4882 if (expr3->ts.type == BT_CLASS)
4885 gfc_expr *sz = gfc_copy_expr (expr3);
4886 gfc_add_vptr_component (sz);
4887 gfc_add_size_component (sz);
4888 gfc_init_se (&se_sz, NULL);
4889 gfc_conv_expr (&se_sz, sz);
4895 tmp = gfc_typenode_for_spec (&expr3->ts);
4896 tmp = TYPE_SIZE_UNIT (tmp);
4900 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4902 /* Convert to size_t. */
4903 element_size = fold_convert (size_type_node, tmp);
4906 return element_size;
4908 *nelems = gfc_evaluate_now (stride, pblock);
4909 stride = fold_convert (size_type_node, stride);
4911 /* First check for overflow. Since an array of type character can
4912 have zero element_size, we must check for that before
4914 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4916 TYPE_MAX_VALUE (size_type_node), element_size);
4917 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4918 boolean_type_node, tmp, stride));
4919 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4920 integer_one_node, integer_zero_node);
4921 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4922 boolean_type_node, element_size,
4923 build_int_cst (size_type_node, 0)));
4924 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4925 integer_zero_node, tmp);
4926 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4928 *overflow = gfc_evaluate_now (tmp, pblock);
4930 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4931 stride, element_size);
4933 if (poffset != NULL)
4935 offset = gfc_evaluate_now (offset, pblock);
4939 if (integer_zerop (or_expr))
4941 if (integer_onep (or_expr))
4942 return build_int_cst (size_type_node, 0);
4944 var = gfc_create_var (TREE_TYPE (size), "size");
4945 gfc_start_block (&thenblock);
4946 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4947 thencase = gfc_finish_block (&thenblock);
4949 gfc_start_block (&elseblock);
4950 gfc_add_modify (&elseblock, var, size);
4951 elsecase = gfc_finish_block (&elseblock);
4953 tmp = gfc_evaluate_now (or_expr, pblock);
4954 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4955 gfc_add_expr_to_block (pblock, tmp);
4961 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4962 the work for an ALLOCATE statement. */
4966 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4967 tree errlen, tree label_finish, tree expr3_elem_size,
4968 tree *nelems, gfc_expr *expr3)
4972 tree offset = NULL_TREE;
4973 tree token = NULL_TREE;
4976 tree error = NULL_TREE;
4977 tree overflow; /* Boolean storing whether size calculation overflows. */
4978 tree var_overflow = NULL_TREE;
4980 tree set_descriptor;
4981 stmtblock_t set_descriptor_block;
4982 stmtblock_t elseblock;
4985 gfc_ref *ref, *prev_ref = NULL;
4986 bool allocatable, coarray, dimension;
4990 /* Find the last reference in the chain. */
4991 while (ref && ref->next != NULL)
4993 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4994 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4999 if (ref == NULL || ref->type != REF_ARRAY)
5004 allocatable = expr->symtree->n.sym->attr.allocatable;
5005 coarray = expr->symtree->n.sym->attr.codimension;
5006 dimension = expr->symtree->n.sym->attr.dimension;
5010 allocatable = prev_ref->u.c.component->attr.allocatable;
5011 coarray = prev_ref->u.c.component->attr.codimension;
5012 dimension = prev_ref->u.c.component->attr.dimension;
5016 gcc_assert (coarray);
5018 /* Figure out the size of the array. */
5019 switch (ref->u.ar.type)
5025 upper = ref->u.ar.start;
5031 lower = ref->u.ar.start;
5032 upper = ref->u.ar.end;
5036 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
5038 lower = ref->u.ar.as->lower;
5039 upper = ref->u.ar.as->upper;
5047 overflow = integer_zero_node;
5049 gfc_init_block (&set_descriptor_block);
5050 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
5051 ref->u.ar.as->corank, &offset, lower, upper,
5052 &se->pre, &set_descriptor_block, &overflow,
5053 expr3_elem_size, nelems, expr3);
5058 var_overflow = gfc_create_var (integer_type_node, "overflow");
5059 gfc_add_modify (&se->pre, var_overflow, overflow);
5061 /* Generate the block of code handling overflow. */
5062 msg = gfc_build_addr_expr (pchar_type_node,
5063 gfc_build_localized_cstring_const
5064 ("Integer overflow when calculating the amount of "
5065 "memory to allocate"));
5066 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
5070 if (status != NULL_TREE)
5072 tree status_type = TREE_TYPE (status);
5073 stmtblock_t set_status_block;
5075 gfc_start_block (&set_status_block);
5076 gfc_add_modify (&set_status_block, status,
5077 build_int_cst (status_type, LIBERROR_ALLOCATION));
5078 error = gfc_finish_block (&set_status_block);
5081 gfc_start_block (&elseblock);
5083 /* Allocate memory to store the data. */
5084 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5085 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5087 pointer = gfc_conv_descriptor_data_get (se->expr);
5088 STRIP_NOPS (pointer);
5090 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5091 token = gfc_build_addr_expr (NULL_TREE,
5092 gfc_conv_descriptor_token (se->expr));
5094 /* The allocatable variant takes the old pointer as first argument. */
5096 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5097 status, errmsg, errlen, label_finish, expr);
5099 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5103 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5104 boolean_type_node, var_overflow, integer_zero_node));
5105 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5106 error, gfc_finish_block (&elseblock));
5109 tmp = gfc_finish_block (&elseblock);
5111 gfc_add_expr_to_block (&se->pre, tmp);
5113 if (expr->ts.type == BT_CLASS)
5115 tmp = build_int_cst (unsigned_char_type_node, 0);
5116 /* With class objects, it is best to play safe and null the
5117 memory because we cannot know if dynamic types have allocatable
5118 components or not. */
5119 tmp = build_call_expr_loc (input_location,
5120 builtin_decl_explicit (BUILT_IN_MEMSET),
5121 3, pointer, tmp, size);
5122 gfc_add_expr_to_block (&se->pre, tmp);
5125 /* Update the array descriptors. */
5127 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
5129 set_descriptor = gfc_finish_block (&set_descriptor_block);
5130 if (status != NULL_TREE)
5132 cond = fold_build2_loc (input_location, EQ_EXPR,
5133 boolean_type_node, status,
5134 build_int_cst (TREE_TYPE (status), 0));
5135 gfc_add_expr_to_block (&se->pre,
5136 fold_build3_loc (input_location, COND_EXPR, void_type_node,
5137 gfc_likely (cond), set_descriptor,
5138 build_empty_stmt (input_location)));
5141 gfc_add_expr_to_block (&se->pre, set_descriptor);
5143 if ((expr->ts.type == BT_DERIVED)
5144 && expr->ts.u.derived->attr.alloc_comp)
5146 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
5147 ref->u.ar.as->rank);
5148 gfc_add_expr_to_block (&se->pre, tmp);
5155 /* Deallocate an array variable. Also used when an allocated variable goes
5160 gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
5161 tree label_finish, gfc_expr* expr)
5166 bool coarray = gfc_is_coarray (expr);
5168 gfc_start_block (&block);
5170 /* Get a pointer to the data. */
5171 var = gfc_conv_descriptor_data_get (descriptor);
5174 /* Parameter is the address of the data component. */
5175 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
5176 errlen, label_finish, false, expr, coarray);
5177 gfc_add_expr_to_block (&block, tmp);
5179 /* Zero the data pointer; only for coarrays an error can occur and then
5180 the allocation status may not be changed. */
5181 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5182 var, build_int_cst (TREE_TYPE (var), 0));
5183 if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5186 tree stat = build_fold_indirect_ref_loc (input_location, pstat);
5188 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5189 stat, build_int_cst (TREE_TYPE (stat), 0));
5190 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5191 cond, tmp, build_empty_stmt (input_location));
5194 gfc_add_expr_to_block (&block, tmp);
5196 return gfc_finish_block (&block);
5200 /* Create an array constructor from an initialization expression.
5201 We assume the frontend already did any expansions and conversions. */
5204 gfc_conv_array_initializer (tree type, gfc_expr * expr)
5210 unsigned HOST_WIDE_INT lo;
5212 VEC(constructor_elt,gc) *v = NULL;
5214 if (expr->expr_type == EXPR_VARIABLE
5215 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5216 && expr->symtree->n.sym->value)
5217 expr = expr->symtree->n.sym->value;
5219 switch (expr->expr_type)
5222 case EXPR_STRUCTURE:
5223 /* A single scalar or derived type value. Create an array with all
5224 elements equal to that value. */
5225 gfc_init_se (&se, NULL);
5227 if (expr->expr_type == EXPR_CONSTANT)
5228 gfc_conv_constant (&se, expr);
5230 gfc_conv_structure (&se, expr, 1);
5232 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
5233 gcc_assert (tmp && INTEGER_CST_P (tmp));
5234 hi = TREE_INT_CST_HIGH (tmp);
5235 lo = TREE_INT_CST_LOW (tmp);
5239 /* This will probably eat buckets of memory for large arrays. */
5240 while (hi != 0 || lo != 0)
5242 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
5250 /* Create a vector of all the elements. */
5251 for (c = gfc_constructor_first (expr->value.constructor);
5252 c; c = gfc_constructor_next (c))
5256 /* Problems occur when we get something like
5257 integer :: a(lots) = (/(i, i=1, lots)/) */
5258 gfc_fatal_error ("The number of elements in the array constructor "
5259 "at %L requires an increase of the allowed %d "
5260 "upper limit. See -fmax-array-constructor "
5261 "option", &expr->where,
5262 gfc_option.flag_max_array_constructor);
5265 if (mpz_cmp_si (c->offset, 0) != 0)
5266 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5270 if (mpz_cmp_si (c->repeat, 1) > 0)
5276 mpz_add (maxval, c->offset, c->repeat);
5277 mpz_sub_ui (maxval, maxval, 1);
5278 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5279 if (mpz_cmp_si (c->offset, 0) != 0)
5281 mpz_add_ui (maxval, c->offset, 1);
5282 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5285 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5287 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
5293 gfc_init_se (&se, NULL);
5294 switch (c->expr->expr_type)
5297 gfc_conv_constant (&se, c->expr);
5300 case EXPR_STRUCTURE:
5301 gfc_conv_structure (&se, c->expr, 1);
5305 /* Catch those occasional beasts that do not simplify
5306 for one reason or another, assuming that if they are
5307 standard defying the frontend will catch them. */
5308 gfc_conv_expr (&se, c->expr);
5312 if (range == NULL_TREE)
5313 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5316 if (index != NULL_TREE)
5317 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5318 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
5324 return gfc_build_null_descriptor (type);
5330 /* Create a constructor from the list of elements. */
5331 tmp = build_constructor (type, v);
5332 TREE_CONSTANT (tmp) = 1;
5337 /* Generate code to evaluate non-constant coarray cobounds. */
5340 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
5341 const gfc_symbol *sym)
5351 for (dim = as->rank; dim < as->rank + as->corank; dim++)
5353 /* Evaluate non-constant array bound expressions. */
5354 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5355 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5357 gfc_init_se (&se, NULL);
5358 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5359 gfc_add_block_to_block (pblock, &se.pre);
5360 gfc_add_modify (pblock, lbound, se.expr);
5362 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5363 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5365 gfc_init_se (&se, NULL);
5366 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5367 gfc_add_block_to_block (pblock, &se.pre);
5368 gfc_add_modify (pblock, ubound, se.expr);
5374 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5375 returns the size (in elements) of the array. */
5378 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
5379 stmtblock_t * pblock)
5394 size = gfc_index_one_node;
5395 offset = gfc_index_zero_node;
5396 for (dim = 0; dim < as->rank; dim++)
5398 /* Evaluate non-constant array bound expressions. */
5399 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5400 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5402 gfc_init_se (&se, NULL);
5403 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5404 gfc_add_block_to_block (pblock, &se.pre);
5405 gfc_add_modify (pblock, lbound, se.expr);
5407 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5408 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5410 gfc_init_se (&se, NULL);
5411 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5412 gfc_add_block_to_block (pblock, &se.pre);
5413 gfc_add_modify (pblock, ubound, se.expr);
5415 /* The offset of this dimension. offset = offset - lbound * stride. */
5416 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5418 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5421 /* The size of this dimension, and the stride of the next. */
5422 if (dim + 1 < as->rank)
5423 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5425 stride = GFC_TYPE_ARRAY_SIZE (type);
5427 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5429 /* Calculate stride = size * (ubound + 1 - lbound). */
5430 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5431 gfc_array_index_type,
5432 gfc_index_one_node, lbound);
5433 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5434 gfc_array_index_type, ubound, tmp);
5435 tmp = fold_build2_loc (input_location, MULT_EXPR,
5436 gfc_array_index_type, size, tmp);
5438 gfc_add_modify (pblock, stride, tmp);
5440 stride = gfc_evaluate_now (tmp, pblock);
5442 /* Make sure that negative size arrays are translated
5443 to being zero size. */
5444 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5445 stride, gfc_index_zero_node);
5446 tmp = fold_build3_loc (input_location, COND_EXPR,
5447 gfc_array_index_type, tmp,
5448 stride, gfc_index_zero_node);
5449 gfc_add_modify (pblock, stride, tmp);
5455 gfc_trans_array_cobounds (type, pblock, sym);
5456 gfc_trans_vla_type_sizes (sym, pblock);
5463 /* Generate code to initialize/allocate an array variable. */
5466 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5467 gfc_wrapped_block * block)
5471 tree tmp = NULL_TREE;
5478 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5480 /* Do nothing for USEd variables. */
5481 if (sym->attr.use_assoc)
5484 type = TREE_TYPE (decl);
5485 gcc_assert (GFC_ARRAY_TYPE_P (type));
5486 onstack = TREE_CODE (type) != POINTER_TYPE;
5488 gfc_init_block (&init);
5490 /* Evaluate character string length. */
5491 if (sym->ts.type == BT_CHARACTER
5492 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5494 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5496 gfc_trans_vla_type_sizes (sym, &init);
5498 /* Emit a DECL_EXPR for this variable, which will cause the
5499 gimplifier to allocate storage, and all that good stuff. */
5500 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5501 gfc_add_expr_to_block (&init, tmp);
5506 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5510 type = TREE_TYPE (type);
5512 gcc_assert (!sym->attr.use_assoc);
5513 gcc_assert (!TREE_STATIC (decl));
5514 gcc_assert (!sym->module);
5516 if (sym->ts.type == BT_CHARACTER
5517 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5518 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5520 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5522 /* Don't actually allocate space for Cray Pointees. */
5523 if (sym->attr.cray_pointee)
5525 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5526 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5528 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5532 if (gfc_option.flag_stack_arrays)
5534 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5535 space = build_decl (sym->declared_at.lb->location,
5536 VAR_DECL, create_tmp_var_name ("A"),
5537 TREE_TYPE (TREE_TYPE (decl)));
5538 gfc_trans_vla_type_sizes (sym, &init);
5542 /* The size is the number of elements in the array, so multiply by the
5543 size of an element to get the total size. */
5544 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5545 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5546 size, fold_convert (gfc_array_index_type, tmp));
5548 /* Allocate memory to hold the data. */
5549 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5550 gfc_add_modify (&init, decl, tmp);
5552 /* Free the temporary. */
5553 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5557 /* Set offset of the array. */
5558 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5559 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5561 /* Automatic arrays should not have initializers. */
5562 gcc_assert (!sym->value);
5564 inittree = gfc_finish_block (&init);
5571 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5572 where also space is located. */
5573 gfc_init_block (&init);
5574 tmp = fold_build1_loc (input_location, DECL_EXPR,
5575 TREE_TYPE (space), space);
5576 gfc_add_expr_to_block (&init, tmp);
5577 addr = fold_build1_loc (sym->declared_at.lb->location,
5578 ADDR_EXPR, TREE_TYPE (decl), space);
5579 gfc_add_modify (&init, decl, addr);
5580 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5583 gfc_add_init_cleanup (block, inittree, tmp);
5587 /* Generate entry and exit code for g77 calling convention arrays. */
5590 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5600 gfc_save_backend_locus (&loc);
5601 gfc_set_backend_locus (&sym->declared_at);
5603 /* Descriptor type. */
5604 parm = sym->backend_decl;
5605 type = TREE_TYPE (parm);
5606 gcc_assert (GFC_ARRAY_TYPE_P (type));
5608 gfc_start_block (&init);
5610 if (sym->ts.type == BT_CHARACTER
5611 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5612 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5614 /* Evaluate the bounds of the array. */
5615 gfc_trans_array_bounds (type, sym, &offset, &init);
5617 /* Set the offset. */
5618 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5619 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5621 /* Set the pointer itself if we aren't using the parameter directly. */
5622 if (TREE_CODE (parm) != PARM_DECL)
5624 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5625 gfc_add_modify (&init, parm, tmp);
5627 stmt = gfc_finish_block (&init);
5629 gfc_restore_backend_locus (&loc);
5631 /* Add the initialization code to the start of the function. */
5633 if (sym->attr.optional || sym->attr.not_always_present)
5635 tmp = gfc_conv_expr_present (sym);
5636 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5639 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5643 /* Modify the descriptor of an array parameter so that it has the
5644 correct lower bound. Also move the upper bound accordingly.
5645 If the array is not packed, it will be copied into a temporary.
5646 For each dimension we set the new lower and upper bounds. Then we copy the
5647 stride and calculate the offset for this dimension. We also work out
5648 what the stride of a packed array would be, and see it the two match.
5649 If the array need repacking, we set the stride to the values we just
5650 calculated, recalculate the offset and copy the array data.
5651 Code is also added to copy the data back at the end of the function.
5655 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5656 gfc_wrapped_block * block)
5663 tree stmtInit, stmtCleanup;
5670 tree stride, stride2;
5680 /* Do nothing for pointer and allocatable arrays. */
5681 if (sym->attr.pointer || sym->attr.allocatable)
5684 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5686 gfc_trans_g77_array (sym, block);
5690 gfc_save_backend_locus (&loc);
5691 gfc_set_backend_locus (&sym->declared_at);
5693 /* Descriptor type. */
5694 type = TREE_TYPE (tmpdesc);
5695 gcc_assert (GFC_ARRAY_TYPE_P (type));
5696 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5697 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5698 gfc_start_block (&init);
5700 if (sym->ts.type == BT_CHARACTER
5701 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5702 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5704 checkparm = (sym->as->type == AS_EXPLICIT
5705 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5707 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5708 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5710 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5712 /* For non-constant shape arrays we only check if the first dimension
5713 is contiguous. Repacking higher dimensions wouldn't gain us
5714 anything as we still don't know the array stride. */
5715 partial = gfc_create_var (boolean_type_node, "partial");
5716 TREE_USED (partial) = 1;
5717 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5718 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5719 gfc_index_one_node);
5720 gfc_add_modify (&init, partial, tmp);
5723 partial = NULL_TREE;
5725 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5726 here, however I think it does the right thing. */
5729 /* Set the first stride. */
5730 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5731 stride = gfc_evaluate_now (stride, &init);
5733 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5734 stride, gfc_index_zero_node);
5735 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5736 tmp, gfc_index_one_node, stride);
5737 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5738 gfc_add_modify (&init, stride, tmp);
5740 /* Allow the user to disable array repacking. */
5741 stmt_unpacked = NULL_TREE;
5745 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5746 /* A library call to repack the array if necessary. */
5747 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5748 stmt_unpacked = build_call_expr_loc (input_location,
5749 gfor_fndecl_in_pack, 1, tmp);
5751 stride = gfc_index_one_node;
5753 if (gfc_option.warn_array_temp)
5754 gfc_warning ("Creating array temporary at %L", &loc);
5757 /* This is for the case where the array data is used directly without
5758 calling the repack function. */
5759 if (no_repack || partial != NULL_TREE)
5760 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5762 stmt_packed = NULL_TREE;
5764 /* Assign the data pointer. */
5765 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5767 /* Don't repack unknown shape arrays when the first stride is 1. */
5768 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5769 partial, stmt_packed, stmt_unpacked);
5772 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5773 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5775 offset = gfc_index_zero_node;
5776 size = gfc_index_one_node;
5778 /* Evaluate the bounds of the array. */
5779 for (n = 0; n < sym->as->rank; n++)
5781 if (checkparm || !sym->as->upper[n])
5783 /* Get the bounds of the actual parameter. */
5784 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5785 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5789 dubound = NULL_TREE;
5790 dlbound = NULL_TREE;
5793 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5794 if (!INTEGER_CST_P (lbound))
5796 gfc_init_se (&se, NULL);
5797 gfc_conv_expr_type (&se, sym->as->lower[n],
5798 gfc_array_index_type);
5799 gfc_add_block_to_block (&init, &se.pre);
5800 gfc_add_modify (&init, lbound, se.expr);
5803 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5804 /* Set the desired upper bound. */
5805 if (sym->as->upper[n])
5807 /* We know what we want the upper bound to be. */
5808 if (!INTEGER_CST_P (ubound))
5810 gfc_init_se (&se, NULL);
5811 gfc_conv_expr_type (&se, sym->as->upper[n],
5812 gfc_array_index_type);
5813 gfc_add_block_to_block (&init, &se.pre);
5814 gfc_add_modify (&init, ubound, se.expr);
5817 /* Check the sizes match. */
5820 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5824 temp = fold_build2_loc (input_location, MINUS_EXPR,
5825 gfc_array_index_type, ubound, lbound);
5826 temp = fold_build2_loc (input_location, PLUS_EXPR,
5827 gfc_array_index_type,
5828 gfc_index_one_node, temp);
5829 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5830 gfc_array_index_type, dubound,
5832 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5833 gfc_array_index_type,
5834 gfc_index_one_node, stride2);
5835 tmp = fold_build2_loc (input_location, NE_EXPR,
5836 gfc_array_index_type, temp, stride2);
5837 asprintf (&msg, "Dimension %d of array '%s' has extent "
5838 "%%ld instead of %%ld", n+1, sym->name);
5840 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5841 fold_convert (long_integer_type_node, temp),
5842 fold_convert (long_integer_type_node, stride2));
5849 /* For assumed shape arrays move the upper bound by the same amount
5850 as the lower bound. */
5851 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5852 gfc_array_index_type, dubound, dlbound);
5853 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5854 gfc_array_index_type, tmp, lbound);
5855 gfc_add_modify (&init, ubound, tmp);
5857 /* The offset of this dimension. offset = offset - lbound * stride. */
5858 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5860 offset = fold_build2_loc (input_location, MINUS_EXPR,
5861 gfc_array_index_type, offset, tmp);
5863 /* The size of this dimension, and the stride of the next. */
5864 if (n + 1 < sym->as->rank)
5866 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5868 if (no_repack || partial != NULL_TREE)
5870 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5872 /* Figure out the stride if not a known constant. */
5873 if (!INTEGER_CST_P (stride))
5876 stmt_packed = NULL_TREE;
5879 /* Calculate stride = size * (ubound + 1 - lbound). */
5880 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5881 gfc_array_index_type,
5882 gfc_index_one_node, lbound);
5883 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5884 gfc_array_index_type, ubound, tmp);
5885 size = fold_build2_loc (input_location, MULT_EXPR,
5886 gfc_array_index_type, size, tmp);
5890 /* Assign the stride. */
5891 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5892 tmp = fold_build3_loc (input_location, COND_EXPR,
5893 gfc_array_index_type, partial,
5894 stmt_unpacked, stmt_packed);
5896 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5897 gfc_add_modify (&init, stride, tmp);
5902 stride = GFC_TYPE_ARRAY_SIZE (type);
5904 if (stride && !INTEGER_CST_P (stride))
5906 /* Calculate size = stride * (ubound + 1 - lbound). */
5907 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5908 gfc_array_index_type,
5909 gfc_index_one_node, lbound);
5910 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5911 gfc_array_index_type,
5913 tmp = fold_build2_loc (input_location, MULT_EXPR,
5914 gfc_array_index_type,
5915 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5916 gfc_add_modify (&init, stride, tmp);
5921 gfc_trans_array_cobounds (type, &init, sym);
5923 /* Set the offset. */
5924 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5925 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5927 gfc_trans_vla_type_sizes (sym, &init);
5929 stmtInit = gfc_finish_block (&init);
5931 /* Only do the entry/initialization code if the arg is present. */
5932 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5933 optional_arg = (sym->attr.optional
5934 || (sym->ns->proc_name->attr.entry_master
5935 && sym->attr.dummy));
5938 tmp = gfc_conv_expr_present (sym);
5939 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5940 build_empty_stmt (input_location));
5945 stmtCleanup = NULL_TREE;
5948 stmtblock_t cleanup;
5949 gfc_start_block (&cleanup);
5951 if (sym->attr.intent != INTENT_IN)
5953 /* Copy the data back. */
5954 tmp = build_call_expr_loc (input_location,
5955 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5956 gfc_add_expr_to_block (&cleanup, tmp);
5959 /* Free the temporary. */
5960 tmp = gfc_call_free (tmpdesc);
5961 gfc_add_expr_to_block (&cleanup, tmp);
5963 stmtCleanup = gfc_finish_block (&cleanup);
5965 /* Only do the cleanup if the array was repacked. */
5966 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5967 tmp = gfc_conv_descriptor_data_get (tmp);
5968 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5970 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5971 build_empty_stmt (input_location));
5975 tmp = gfc_conv_expr_present (sym);
5976 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5977 build_empty_stmt (input_location));
5981 /* We don't need to free any memory allocated by internal_pack as it will
5982 be freed at the end of the function by pop_context. */
5983 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5985 gfc_restore_backend_locus (&loc);
5989 /* Calculate the overall offset, including subreferences. */
5991 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5992 bool subref, gfc_expr *expr)
6002 /* If offset is NULL and this is not a subreferenced array, there is
6004 if (offset == NULL_TREE)
6007 offset = gfc_index_zero_node;
6012 tmp = gfc_conv_array_data (desc);
6013 tmp = build_fold_indirect_ref_loc (input_location,
6015 tmp = gfc_build_array_ref (tmp, offset, NULL);
6017 /* Offset the data pointer for pointer assignments from arrays with
6018 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6021 /* Go past the array reference. */
6022 for (ref = expr->ref; ref; ref = ref->next)
6023 if (ref->type == REF_ARRAY &&
6024 ref->u.ar.type != AR_ELEMENT)
6030 /* Calculate the offset for each subsequent subreference. */
6031 for (; ref; ref = ref->next)
6036 field = ref->u.c.component->backend_decl;
6037 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6038 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6040 tmp, field, NULL_TREE);
6044 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6045 gfc_init_se (&start, NULL);
6046 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6047 gfc_add_block_to_block (block, &start.pre);
6048 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6052 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6053 && ref->u.ar.type == AR_ELEMENT);
6055 /* TODO - Add bounds checking. */
6056 stride = gfc_index_one_node;
6057 index = gfc_index_zero_node;
6058 for (n = 0; n < ref->u.ar.dimen; n++)
6063 /* Update the index. */
6064 gfc_init_se (&start, NULL);
6065 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6066 itmp = gfc_evaluate_now (start.expr, block);
6067 gfc_init_se (&start, NULL);
6068 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6069 jtmp = gfc_evaluate_now (start.expr, block);
6070 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6071 gfc_array_index_type, itmp, jtmp);
6072 itmp = fold_build2_loc (input_location, MULT_EXPR,
6073 gfc_array_index_type, itmp, stride);
6074 index = fold_build2_loc (input_location, PLUS_EXPR,
6075 gfc_array_index_type, itmp, index);
6076 index = gfc_evaluate_now (index, block);
6078 /* Update the stride. */
6079 gfc_init_se (&start, NULL);
6080 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6081 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6082 gfc_array_index_type, start.expr,
6084 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6085 gfc_array_index_type,
6086 gfc_index_one_node, itmp);
6087 stride = fold_build2_loc (input_location, MULT_EXPR,
6088 gfc_array_index_type, stride, itmp);
6089 stride = gfc_evaluate_now (stride, block);
6092 /* Apply the index to obtain the array element. */
6093 tmp = gfc_build_array_ref (tmp, index, NULL);
6103 /* Set the target data pointer. */
6104 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6105 gfc_conv_descriptor_data_set (block, parm, offset);
6109 /* gfc_conv_expr_descriptor needs the string length an expression
6110 so that the size of the temporary can be obtained. This is done
6111 by adding up the string lengths of all the elements in the
6112 expression. Function with non-constant expressions have their
6113 string lengths mapped onto the actual arguments using the
6114 interface mapping machinery in trans-expr.c. */
6116 get_array_charlen (gfc_expr *expr, gfc_se *se)
6118 gfc_interface_mapping mapping;
6119 gfc_formal_arglist *formal;
6120 gfc_actual_arglist *arg;
6123 if (expr->ts.u.cl->length
6124 && gfc_is_constant_expr (expr->ts.u.cl->length))
6126 if (!expr->ts.u.cl->backend_decl)
6127 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6131 switch (expr->expr_type)
6134 get_array_charlen (expr->value.op.op1, se);
6136 /* For parentheses the expression ts.u.cl is identical. */
6137 if (expr->value.op.op == INTRINSIC_PARENTHESES)
6140 expr->ts.u.cl->backend_decl =
6141 gfc_create_var (gfc_charlen_type_node, "sln");
6143 if (expr->value.op.op2)
6145 get_array_charlen (expr->value.op.op2, se);
6147 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
6149 /* Add the string lengths and assign them to the expression
6150 string length backend declaration. */
6151 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6152 fold_build2_loc (input_location, PLUS_EXPR,
6153 gfc_charlen_type_node,
6154 expr->value.op.op1->ts.u.cl->backend_decl,
6155 expr->value.op.op2->ts.u.cl->backend_decl));
6158 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6159 expr->value.op.op1->ts.u.cl->backend_decl);
6163 if (expr->value.function.esym == NULL
6164 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6166 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6170 /* Map expressions involving the dummy arguments onto the actual
6171 argument expressions. */
6172 gfc_init_interface_mapping (&mapping);
6173 formal = expr->symtree->n.sym->formal;
6174 arg = expr->value.function.actual;
6176 /* Set se = NULL in the calls to the interface mapping, to suppress any
6178 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
6183 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
6186 gfc_init_se (&tse, NULL);
6188 /* Build the expression for the character length and convert it. */
6189 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
6191 gfc_add_block_to_block (&se->pre, &tse.pre);
6192 gfc_add_block_to_block (&se->post, &tse.post);
6193 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
6194 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
6195 gfc_charlen_type_node, tse.expr,
6196 build_int_cst (gfc_charlen_type_node, 0));
6197 expr->ts.u.cl->backend_decl = tse.expr;
6198 gfc_free_interface_mapping (&mapping);
6202 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6208 /* Helper function to check dimensions. */
6210 transposed_dims (gfc_ss *ss)
6214 for (n = 0; n < ss->dimen; n++)
6215 if (ss->dim[n] != n)
6220 /* Convert an array for passing as an actual argument. Expressions and
6221 vector subscripts are evaluated and stored in a temporary, which is then
6222 passed. For whole arrays the descriptor is passed. For array sections
6223 a modified copy of the descriptor is passed, but using the original data.
6225 This function is also used for array pointer assignments, and there
6228 - se->want_pointer && !se->direct_byref
6229 EXPR is an actual argument. On exit, se->expr contains a
6230 pointer to the array descriptor.
6232 - !se->want_pointer && !se->direct_byref
6233 EXPR is an actual argument to an intrinsic function or the
6234 left-hand side of a pointer assignment. On exit, se->expr
6235 contains the descriptor for EXPR.
6237 - !se->want_pointer && se->direct_byref
6238 EXPR is the right-hand side of a pointer assignment and
6239 se->expr is the descriptor for the previously-evaluated
6240 left-hand side. The function creates an assignment from
6244 The se->force_tmp flag disables the non-copying descriptor optimization
6245 that is used for transpose. It may be used in cases where there is an
6246 alias between the transpose argument and another argument in the same
6250 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
6252 gfc_ss_type ss_type;
6253 gfc_ss_info *ss_info;
6255 gfc_array_info *info;
6264 bool subref_array_target = false;
6265 gfc_expr *arg, *ss_expr;
6267 gcc_assert (ss != NULL);
6268 gcc_assert (ss != gfc_ss_terminator);
6271 ss_type = ss_info->type;
6272 ss_expr = ss_info->expr;
6274 /* Special case things we know we can pass easily. */
6275 switch (expr->expr_type)
6278 /* If we have a linear array section, we can pass it directly.
6279 Otherwise we need to copy it into a temporary. */
6281 gcc_assert (ss_type == GFC_SS_SECTION);
6282 gcc_assert (ss_expr == expr);
6283 info = &ss_info->data.array;
6285 /* Get the descriptor for the array. */
6286 gfc_conv_ss_descriptor (&se->pre, ss, 0);
6287 desc = info->descriptor;
6289 subref_array_target = se->direct_byref && is_subref_array (expr);
6290 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
6291 && !subref_array_target;
6298 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6300 /* Create a new descriptor if the array doesn't have one. */
6303 else if (info->ref->u.ar.type == AR_FULL)
6305 else if (se->direct_byref)
6308 full = gfc_full_array_ref_p (info->ref, NULL);
6310 if (full && !transposed_dims (ss))
6312 if (se->direct_byref && !se->byref_noassign)
6314 /* Copy the descriptor for pointer assignments. */
6315 gfc_add_modify (&se->pre, se->expr, desc);
6317 /* Add any offsets from subreferences. */
6318 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
6319 subref_array_target, expr);
6321 else if (se->want_pointer)
6323 /* We pass full arrays directly. This means that pointers and
6324 allocatable arrays should also work. */
6325 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6332 if (expr->ts.type == BT_CHARACTER)
6333 se->string_length = gfc_get_expr_charlen (expr);
6341 /* We don't need to copy data in some cases. */
6342 arg = gfc_get_noncopying_intrinsic_argument (expr);
6345 /* This is a call to transpose... */
6346 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6347 /* ... which has already been handled by the scalarizer, so
6348 that we just need to get its argument's descriptor. */
6349 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
6353 /* A transformational function return value will be a temporary
6354 array descriptor. We still need to go through the scalarizer
6355 to create the descriptor. Elemental functions ar handled as
6356 arbitrary expressions, i.e. copy to a temporary. */
6358 if (se->direct_byref)
6360 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
6362 /* For pointer assignments pass the descriptor directly. */
6366 gcc_assert (se->ss == ss);
6367 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6368 gfc_conv_expr (se, expr);
6372 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
6374 if (ss_expr != expr)
6375 /* Elemental function. */
6376 gcc_assert ((expr->value.function.esym != NULL
6377 && expr->value.function.esym->attr.elemental)
6378 || (expr->value.function.isym != NULL
6379 && expr->value.function.isym->elemental)
6380 || gfc_inline_intrinsic_function_p (expr));
6382 gcc_assert (ss_type == GFC_SS_INTRINSIC);
6385 if (expr->ts.type == BT_CHARACTER
6386 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6387 get_array_charlen (expr, se);
6393 /* Transformational function. */
6394 info = &ss_info->data.array;
6400 /* Constant array constructors don't need a temporary. */
6401 if (ss_type == GFC_SS_CONSTRUCTOR
6402 && expr->ts.type != BT_CHARACTER
6403 && gfc_constant_array_constructor_p (expr->value.constructor))
6406 info = &ss_info->data.array;
6416 /* Something complicated. Copy it into a temporary. */
6422 /* If we are creating a temporary, we don't need to bother about aliases
6427 gfc_init_loopinfo (&loop);
6429 /* Associate the SS with the loop. */
6430 gfc_add_ss_to_loop (&loop, ss);
6432 /* Tell the scalarizer not to bother creating loop variables, etc. */
6434 loop.array_parameter = 1;
6436 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6437 gcc_assert (!se->direct_byref);
6439 /* Setup the scalarizing loops and bounds. */
6440 gfc_conv_ss_startstride (&loop);
6444 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6445 get_array_charlen (expr, se);
6447 /* Tell the scalarizer to make a temporary. */
6448 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6449 ((expr->ts.type == BT_CHARACTER)
6450 ? expr->ts.u.cl->backend_decl
6454 se->string_length = loop.temp_ss->info->string_length;
6455 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6456 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6459 gfc_conv_loop_setup (&loop, & expr->where);
6463 /* Copy into a temporary and pass that. We don't need to copy the data
6464 back because expressions and vector subscripts must be INTENT_IN. */
6465 /* TODO: Optimize passing function return values. */
6469 /* Start the copying loops. */
6470 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6471 gfc_mark_ss_chain_used (ss, 1);
6472 gfc_start_scalarized_body (&loop, &block);
6474 /* Copy each data element. */
6475 gfc_init_se (&lse, NULL);
6476 gfc_copy_loopinfo_to_se (&lse, &loop);
6477 gfc_init_se (&rse, NULL);
6478 gfc_copy_loopinfo_to_se (&rse, &loop);
6480 lse.ss = loop.temp_ss;
6483 gfc_conv_scalarized_array_ref (&lse, NULL);
6484 if (expr->ts.type == BT_CHARACTER)
6486 gfc_conv_expr (&rse, expr);
6487 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6488 rse.expr = build_fold_indirect_ref_loc (input_location,
6492 gfc_conv_expr_val (&rse, expr);
6494 gfc_add_block_to_block (&block, &rse.pre);
6495 gfc_add_block_to_block (&block, &lse.pre);
6497 lse.string_length = rse.string_length;
6498 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6499 expr->expr_type == EXPR_VARIABLE
6500 || expr->expr_type == EXPR_ARRAY, true);
6501 gfc_add_expr_to_block (&block, tmp);
6503 /* Finish the copying loops. */
6504 gfc_trans_scalarizing_loops (&loop, &block);
6506 desc = loop.temp_ss->info->data.array.descriptor;
6508 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6510 desc = info->descriptor;
6511 se->string_length = ss_info->string_length;
6515 /* We pass sections without copying to a temporary. Make a new
6516 descriptor and point it at the section we want. The loop variable
6517 limits will be the limits of the section.
6518 A function may decide to repack the array to speed up access, but
6519 we're not bothered about that here. */
6520 int dim, ndim, codim;
6528 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6530 if (se->want_coarray)
6532 gfc_array_ref *ar = &info->ref->u.ar;
6534 codim = gfc_get_corank (expr);
6535 for (n = 0; n < codim - 1; n++)
6537 /* Make sure we are not lost somehow. */
6538 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6540 /* Make sure the call to gfc_conv_section_startstride won't
6541 generate unnecessary code to calculate stride. */
6542 gcc_assert (ar->stride[n + ndim] == NULL);
6544 gfc_conv_section_startstride (&loop, ss, n + ndim);
6545 loop.from[n + loop.dimen] = info->start[n + ndim];
6546 loop.to[n + loop.dimen] = info->end[n + ndim];
6549 gcc_assert (n == codim - 1);
6550 evaluate_bound (&loop.pre, info->start, ar->start,
6551 info->descriptor, n + ndim, true);
6552 loop.from[n + loop.dimen] = info->start[n + ndim];
6557 /* Set the string_length for a character array. */
6558 if (expr->ts.type == BT_CHARACTER)
6559 se->string_length = gfc_get_expr_charlen (expr);
6561 desc = info->descriptor;
6562 if (se->direct_byref && !se->byref_noassign)
6564 /* For pointer assignments we fill in the destination. */
6566 parmtype = TREE_TYPE (parm);
6570 /* Otherwise make a new one. */
6571 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6572 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6573 loop.from, loop.to, 0,
6574 GFC_ARRAY_UNKNOWN, false);
6575 parm = gfc_create_var (parmtype, "parm");
6578 offset = gfc_index_zero_node;
6580 /* The following can be somewhat confusing. We have two
6581 descriptors, a new one and the original array.
6582 {parm, parmtype, dim} refer to the new one.
6583 {desc, type, n, loop} refer to the original, which maybe
6584 a descriptorless array.
6585 The bounds of the scalarization are the bounds of the section.
6586 We don't have to worry about numeric overflows when calculating
6587 the offsets because all elements are within the array data. */
6589 /* Set the dtype. */
6590 tmp = gfc_conv_descriptor_dtype (parm);
6591 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6593 /* Set offset for assignments to pointer only to zero if it is not
6595 if (se->direct_byref
6596 && info->ref && info->ref->u.ar.type != AR_FULL)
6597 base = gfc_index_zero_node;
6598 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6599 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6603 for (n = 0; n < ndim; n++)
6605 stride = gfc_conv_array_stride (desc, n);
6607 /* Work out the offset. */
6609 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6611 gcc_assert (info->subscript[n]
6612 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6613 start = info->subscript[n]->info->data.scalar.value;
6617 /* Evaluate and remember the start of the section. */
6618 start = info->start[n];
6619 stride = gfc_evaluate_now (stride, &loop.pre);
6622 tmp = gfc_conv_array_lbound (desc, n);
6623 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6625 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6627 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6631 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6633 /* For elemental dimensions, we only need the offset. */
6637 /* Vector subscripts need copying and are handled elsewhere. */
6639 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6641 /* look for the corresponding scalarizer dimension: dim. */
6642 for (dim = 0; dim < ndim; dim++)
6643 if (ss->dim[dim] == n)
6646 /* loop exited early: the DIM being looked for has been found. */
6647 gcc_assert (dim < ndim);
6649 /* Set the new lower bound. */
6650 from = loop.from[dim];
6653 /* If we have an array section or are assigning make sure that
6654 the lower bound is 1. References to the full
6655 array should otherwise keep the original bounds. */
6657 || info->ref->u.ar.type != AR_FULL)
6658 && !integer_onep (from))
6660 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6661 gfc_array_index_type, gfc_index_one_node,
6663 to = fold_build2_loc (input_location, PLUS_EXPR,
6664 gfc_array_index_type, to, tmp);
6665 from = gfc_index_one_node;
6667 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6668 gfc_rank_cst[dim], from);
6670 /* Set the new upper bound. */
6671 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6672 gfc_rank_cst[dim], to);
6674 /* Multiply the stride by the section stride to get the
6676 stride = fold_build2_loc (input_location, MULT_EXPR,
6677 gfc_array_index_type,
6678 stride, info->stride[n]);
6680 if (se->direct_byref
6682 && info->ref->u.ar.type != AR_FULL)
6684 base = fold_build2_loc (input_location, MINUS_EXPR,
6685 TREE_TYPE (base), base, stride);
6687 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6689 tmp = gfc_conv_array_lbound (desc, n);
6690 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6691 TREE_TYPE (base), tmp, loop.from[dim]);
6692 tmp = fold_build2_loc (input_location, MULT_EXPR,
6693 TREE_TYPE (base), tmp,
6694 gfc_conv_array_stride (desc, n));
6695 base = fold_build2_loc (input_location, PLUS_EXPR,
6696 TREE_TYPE (base), tmp, base);
6699 /* Store the new stride. */
6700 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6701 gfc_rank_cst[dim], stride);
6704 for (n = loop.dimen; n < loop.dimen + codim; n++)
6706 from = loop.from[n];
6708 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6709 gfc_rank_cst[n], from);
6710 if (n < loop.dimen + codim - 1)
6711 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6712 gfc_rank_cst[n], to);
6715 if (se->data_not_needed)
6716 gfc_conv_descriptor_data_set (&loop.pre, parm,
6717 gfc_index_zero_node);
6719 /* Point the data pointer at the 1st element in the section. */
6720 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6721 subref_array_target, expr);
6723 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6724 && !se->data_not_needed)
6726 /* Set the offset. */
6727 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6731 /* Only the callee knows what the correct offset it, so just set
6733 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6738 if (!se->direct_byref || se->byref_noassign)
6740 /* Get a pointer to the new descriptor. */
6741 if (se->want_pointer)
6742 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6747 gfc_add_block_to_block (&se->pre, &loop.pre);
6748 gfc_add_block_to_block (&se->post, &loop.post);
6750 /* Cleanup the scalarizer. */
6751 gfc_cleanup_loop (&loop);
6754 /* Helper function for gfc_conv_array_parameter if array size needs to be
6758 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6761 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6762 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6763 else if (expr->rank > 1)
6764 *size = build_call_expr_loc (input_location,
6765 gfor_fndecl_size0, 1,
6766 gfc_build_addr_expr (NULL, desc));
6769 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6770 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6772 *size = fold_build2_loc (input_location, MINUS_EXPR,
6773 gfc_array_index_type, ubound, lbound);
6774 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6775 *size, gfc_index_one_node);
6776 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6777 *size, gfc_index_zero_node);
6779 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6780 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6781 *size, fold_convert (gfc_array_index_type, elem));
6784 /* Convert an array for passing as an actual parameter. */
6785 /* TODO: Optimize passing g77 arrays. */
6788 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6789 const gfc_symbol *fsym, const char *proc_name,
6794 tree tmp = NULL_TREE;
6796 tree parent = DECL_CONTEXT (current_function_decl);
6797 bool full_array_var;
6798 bool this_array_result;
6801 bool array_constructor;
6802 bool good_allocatable;
6803 bool ultimate_ptr_comp;
6804 bool ultimate_alloc_comp;
6809 ultimate_ptr_comp = false;
6810 ultimate_alloc_comp = false;
6812 for (ref = expr->ref; ref; ref = ref->next)
6814 if (ref->next == NULL)
6817 if (ref->type == REF_COMPONENT)
6819 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6820 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6824 full_array_var = false;
6827 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6828 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6830 sym = full_array_var ? expr->symtree->n.sym : NULL;
6832 /* The symbol should have an array specification. */
6833 gcc_assert (!sym || sym->as || ref->u.ar.as);
6835 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6837 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6838 expr->ts.u.cl->backend_decl = tmp;
6839 se->string_length = tmp;
6842 /* Is this the result of the enclosing procedure? */
6843 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6844 if (this_array_result
6845 && (sym->backend_decl != current_function_decl)
6846 && (sym->backend_decl != parent))
6847 this_array_result = false;
6849 /* Passing address of the array if it is not pointer or assumed-shape. */
6850 if (full_array_var && g77 && !this_array_result)
6852 tmp = gfc_get_symbol_decl (sym);
6854 if (sym->ts.type == BT_CHARACTER)
6855 se->string_length = sym->ts.u.cl->backend_decl;
6857 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6859 gfc_conv_expr_descriptor (se, expr, ss);
6860 se->expr = gfc_conv_array_data (se->expr);
6864 if (!sym->attr.pointer
6866 && sym->as->type != AS_ASSUMED_SHAPE
6867 && !sym->attr.allocatable)
6869 /* Some variables are declared directly, others are declared as
6870 pointers and allocated on the heap. */
6871 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6874 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6876 array_parameter_size (tmp, expr, size);
6880 if (sym->attr.allocatable)
6882 if (sym->attr.dummy || sym->attr.result)
6884 gfc_conv_expr_descriptor (se, expr, ss);
6888 array_parameter_size (tmp, expr, size);
6889 se->expr = gfc_conv_array_data (tmp);
6894 /* A convenient reduction in scope. */
6895 contiguous = g77 && !this_array_result && contiguous;
6897 /* There is no need to pack and unpack the array, if it is contiguous
6898 and not a deferred- or assumed-shape array, or if it is simply
6900 no_pack = ((sym && sym->as
6901 && !sym->attr.pointer
6902 && sym->as->type != AS_DEFERRED
6903 && sym->as->type != AS_ASSUMED_SHAPE)
6905 (ref && ref->u.ar.as
6906 && ref->u.ar.as->type != AS_DEFERRED
6907 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6909 gfc_is_simply_contiguous (expr, false));
6911 no_pack = contiguous && no_pack;
6913 /* Array constructors are always contiguous and do not need packing. */
6914 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6916 /* Same is true of contiguous sections from allocatable variables. */
6917 good_allocatable = contiguous
6919 && expr->symtree->n.sym->attr.allocatable;
6921 /* Or ultimate allocatable components. */
6922 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6924 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6926 gfc_conv_expr_descriptor (se, expr, ss);
6927 if (expr->ts.type == BT_CHARACTER)
6928 se->string_length = expr->ts.u.cl->backend_decl;
6930 array_parameter_size (se->expr, expr, size);
6931 se->expr = gfc_conv_array_data (se->expr);
6935 if (this_array_result)
6937 /* Result of the enclosing function. */
6938 gfc_conv_expr_descriptor (se, expr, ss);
6940 array_parameter_size (se->expr, expr, size);
6941 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6943 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6944 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6945 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6952 /* Every other type of array. */
6953 se->want_pointer = 1;
6954 gfc_conv_expr_descriptor (se, expr, ss);
6956 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6961 /* Deallocate the allocatable components of structures that are
6963 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6964 && expr->ts.u.derived->attr.alloc_comp
6965 && expr->expr_type != EXPR_VARIABLE)
6967 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6968 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6970 /* The components shall be deallocated before their containing entity. */
6971 gfc_prepend_expr_to_block (&se->post, tmp);
6974 if (g77 || (fsym && fsym->attr.contiguous
6975 && !gfc_is_simply_contiguous (expr, false)))
6977 tree origptr = NULL_TREE;
6981 /* For contiguous arrays, save the original value of the descriptor. */
6984 origptr = gfc_create_var (pvoid_type_node, "origptr");
6985 tmp = build_fold_indirect_ref_loc (input_location, desc);
6986 tmp = gfc_conv_array_data (tmp);
6987 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6988 TREE_TYPE (origptr), origptr,
6989 fold_convert (TREE_TYPE (origptr), tmp));
6990 gfc_add_expr_to_block (&se->pre, tmp);
6993 /* Repack the array. */
6994 if (gfc_option.warn_array_temp)
6997 gfc_warning ("Creating array temporary at %L for argument '%s'",
6998 &expr->where, fsym->name);
7000 gfc_warning ("Creating array temporary at %L", &expr->where);
7003 ptr = build_call_expr_loc (input_location,
7004 gfor_fndecl_in_pack, 1, desc);
7006 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7008 tmp = gfc_conv_expr_present (sym);
7009 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
7010 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
7011 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
7014 ptr = gfc_evaluate_now (ptr, &se->pre);
7016 /* Use the packed data for the actual argument, except for contiguous arrays,
7017 where the descriptor's data component is set. */
7022 tmp = build_fold_indirect_ref_loc (input_location, desc);
7023 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
7026 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
7030 if (fsym && proc_name)
7031 asprintf (&msg, "An array temporary was created for argument "
7032 "'%s' of procedure '%s'", fsym->name, proc_name);
7034 asprintf (&msg, "An array temporary was created");
7036 tmp = build_fold_indirect_ref_loc (input_location,
7038 tmp = gfc_conv_array_data (tmp);
7039 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7040 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7042 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7043 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7045 gfc_conv_expr_present (sym), tmp);
7047 gfc_trans_runtime_check (false, true, tmp, &se->pre,
7052 gfc_start_block (&block);
7054 /* Copy the data back. */
7055 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
7057 tmp = build_call_expr_loc (input_location,
7058 gfor_fndecl_in_unpack, 2, desc, ptr);
7059 gfc_add_expr_to_block (&block, tmp);
7062 /* Free the temporary. */
7063 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
7064 gfc_add_expr_to_block (&block, tmp);
7066 stmt = gfc_finish_block (&block);
7068 gfc_init_block (&block);
7069 /* Only if it was repacked. This code needs to be executed before the
7070 loop cleanup code. */
7071 tmp = build_fold_indirect_ref_loc (input_location,
7073 tmp = gfc_conv_array_data (tmp);
7074 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7075 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7077 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7078 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7080 gfc_conv_expr_present (sym), tmp);
7082 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
7084 gfc_add_expr_to_block (&block, tmp);
7085 gfc_add_block_to_block (&block, &se->post);
7087 gfc_init_block (&se->post);
7089 /* Reset the descriptor pointer. */
7092 tmp = build_fold_indirect_ref_loc (input_location, desc);
7093 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
7096 gfc_add_block_to_block (&se->post, &block);
7101 /* Generate code to deallocate an array, if it is allocated. */
7104 gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
7110 gfc_start_block (&block);
7112 var = gfc_conv_descriptor_data_get (descriptor);
7115 /* Call array_deallocate with an int * present in the second argument.
7116 Although it is ignored here, it's presence ensures that arrays that
7117 are already deallocated are ignored. */
7118 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
7119 NULL_TREE, NULL_TREE, NULL_TREE, true,
7121 gfc_add_expr_to_block (&block, tmp);
7123 /* Zero the data pointer. */
7124 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7125 var, build_int_cst (TREE_TYPE (var), 0));
7126 gfc_add_expr_to_block (&block, tmp);
7128 return gfc_finish_block (&block);
7132 /* This helper function calculates the size in words of a full array. */
7135 get_full_array_size (stmtblock_t *block, tree decl, int rank)
7140 idx = gfc_rank_cst[rank - 1];
7141 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
7142 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
7143 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7145 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7146 tmp, gfc_index_one_node);
7147 tmp = gfc_evaluate_now (tmp, block);
7149 nelems = gfc_conv_descriptor_stride_get (decl, idx);
7150 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7152 return gfc_evaluate_now (tmp, block);
7156 /* Allocate dest to the same size as src, and copy src -> dest.
7157 If no_malloc is set, only the copy is done. */
7160 duplicate_allocatable (tree dest, tree src, tree type, int rank,
7170 /* If the source is null, set the destination to null. Then,
7171 allocate memory to the destination. */
7172 gfc_init_block (&block);
7176 tmp = null_pointer_node;
7177 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
7178 gfc_add_expr_to_block (&block, tmp);
7179 null_data = gfc_finish_block (&block);
7181 gfc_init_block (&block);
7182 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7185 tmp = gfc_call_malloc (&block, type, size);
7186 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7187 dest, fold_convert (type, tmp));
7188 gfc_add_expr_to_block (&block, tmp);
7191 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7192 tmp = build_call_expr_loc (input_location, tmp, 3,
7197 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7198 null_data = gfc_finish_block (&block);
7200 gfc_init_block (&block);
7201 nelems = get_full_array_size (&block, src, rank);
7202 tmp = fold_convert (gfc_array_index_type,
7203 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7204 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7208 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
7209 tmp = gfc_call_malloc (&block, tmp, size);
7210 gfc_conv_descriptor_data_set (&block, dest, tmp);
7213 /* We know the temporary and the value will be the same length,
7214 so can use memcpy. */
7215 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7216 tmp = build_call_expr_loc (input_location,
7217 tmp, 3, gfc_conv_descriptor_data_get (dest),
7218 gfc_conv_descriptor_data_get (src), size);
7221 gfc_add_expr_to_block (&block, tmp);
7222 tmp = gfc_finish_block (&block);
7224 /* Null the destination if the source is null; otherwise do
7225 the allocate and copy. */
7229 null_cond = gfc_conv_descriptor_data_get (src);
7231 null_cond = convert (pvoid_type_node, null_cond);
7232 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7233 null_cond, null_pointer_node);
7234 return build3_v (COND_EXPR, null_cond, tmp, null_data);
7238 /* Allocate dest to the same size as src, and copy data src -> dest. */
7241 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
7243 return duplicate_allocatable (dest, src, type, rank, false);
7247 /* Copy data src -> dest. */
7250 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
7252 return duplicate_allocatable (dest, src, type, rank, true);
7256 /* Recursively traverse an object of derived type, generating code to
7257 deallocate, nullify or copy allocatable components. This is the work horse
7258 function for the functions named in this enum. */
7260 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
7261 COPY_ONLY_ALLOC_COMP};
7264 structure_alloc_comps (gfc_symbol * der_type, tree decl,
7265 tree dest, int rank, int purpose)
7269 stmtblock_t fnblock;
7270 stmtblock_t loopbody;
7271 stmtblock_t tmpblock;
7282 tree null_cond = NULL_TREE;
7283 bool called_dealloc_with_status;
7285 gfc_init_block (&fnblock);
7287 decl_type = TREE_TYPE (decl);
7289 if ((POINTER_TYPE_P (decl_type) && rank != 0)
7290 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
7292 decl = build_fold_indirect_ref_loc (input_location,
7295 /* Just in case in gets dereferenced. */
7296 decl_type = TREE_TYPE (decl);
7298 /* If this an array of derived types with allocatable components
7299 build a loop and recursively call this function. */
7300 if (TREE_CODE (decl_type) == ARRAY_TYPE
7301 || GFC_DESCRIPTOR_TYPE_P (decl_type))
7303 tmp = gfc_conv_array_data (decl);
7304 var = build_fold_indirect_ref_loc (input_location,
7307 /* Get the number of elements - 1 and set the counter. */
7308 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
7310 /* Use the descriptor for an allocatable array. Since this
7311 is a full array reference, we only need the descriptor
7312 information from dimension = rank. */
7313 tmp = get_full_array_size (&fnblock, decl, rank);
7314 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7315 gfc_array_index_type, tmp,
7316 gfc_index_one_node);
7318 null_cond = gfc_conv_descriptor_data_get (decl);
7319 null_cond = fold_build2_loc (input_location, NE_EXPR,
7320 boolean_type_node, null_cond,
7321 build_int_cst (TREE_TYPE (null_cond), 0));
7325 /* Otherwise use the TYPE_DOMAIN information. */
7326 tmp = array_type_nelts (decl_type);
7327 tmp = fold_convert (gfc_array_index_type, tmp);
7330 /* Remember that this is, in fact, the no. of elements - 1. */
7331 nelems = gfc_evaluate_now (tmp, &fnblock);
7332 index = gfc_create_var (gfc_array_index_type, "S");
7334 /* Build the body of the loop. */
7335 gfc_init_block (&loopbody);
7337 vref = gfc_build_array_ref (var, index, NULL);
7339 if (purpose == COPY_ALLOC_COMP)
7341 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7343 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
7344 gfc_add_expr_to_block (&fnblock, tmp);
7346 tmp = build_fold_indirect_ref_loc (input_location,
7347 gfc_conv_array_data (dest));
7348 dref = gfc_build_array_ref (tmp, index, NULL);
7349 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
7351 else if (purpose == COPY_ONLY_ALLOC_COMP)
7353 tmp = build_fold_indirect_ref_loc (input_location,
7354 gfc_conv_array_data (dest));
7355 dref = gfc_build_array_ref (tmp, index, NULL);
7356 tmp = structure_alloc_comps (der_type, vref, dref, rank,
7360 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
7362 gfc_add_expr_to_block (&loopbody, tmp);
7364 /* Build the loop and return. */
7365 gfc_init_loopinfo (&loop);
7367 loop.from[0] = gfc_index_zero_node;
7368 loop.loopvar[0] = index;
7369 loop.to[0] = nelems;
7370 gfc_trans_scalarizing_loops (&loop, &loopbody);
7371 gfc_add_block_to_block (&fnblock, &loop.pre);
7373 tmp = gfc_finish_block (&fnblock);
7374 if (null_cond != NULL_TREE)
7375 tmp = build3_v (COND_EXPR, null_cond, tmp,
7376 build_empty_stmt (input_location));
7381 /* Otherwise, act on the components or recursively call self to
7382 act on a chain of components. */
7383 for (c = der_type->components; c; c = c->next)
7385 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
7386 || c->ts.type == BT_CLASS)
7387 && c->ts.u.derived->attr.alloc_comp;
7388 cdecl = c->backend_decl;
7389 ctype = TREE_TYPE (cdecl);
7393 case DEALLOCATE_ALLOC_COMP:
7395 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7396 (ie. this function) so generate all the calls and suppress the
7397 recursion from here, if necessary. */
7398 called_dealloc_with_status = false;
7399 gfc_init_block (&tmpblock);
7401 if (c->attr.allocatable
7402 && (c->attr.dimension || c->attr.codimension))
7404 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7405 decl, cdecl, NULL_TREE);
7406 tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
7407 gfc_add_expr_to_block (&tmpblock, tmp);
7409 else if (c->attr.allocatable)
7411 /* Allocatable scalar components. */
7412 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7413 decl, cdecl, NULL_TREE);
7415 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7417 gfc_add_expr_to_block (&tmpblock, tmp);
7418 called_dealloc_with_status = true;
7420 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7421 void_type_node, comp,
7422 build_int_cst (TREE_TYPE (comp), 0));
7423 gfc_add_expr_to_block (&tmpblock, tmp);
7425 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7427 /* Allocatable CLASS components. */
7428 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7429 decl, cdecl, NULL_TREE);
7431 /* Add reference to '_data' component. */
7432 tmp = CLASS_DATA (c)->backend_decl;
7433 comp = fold_build3_loc (input_location, COMPONENT_REF,
7434 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7436 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
7437 tmp = gfc_trans_dealloc_allocated (comp,
7438 CLASS_DATA (c)->attr.codimension);
7441 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7442 CLASS_DATA (c)->ts);
7443 gfc_add_expr_to_block (&tmpblock, tmp);
7444 called_dealloc_with_status = true;
7446 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7447 void_type_node, comp,
7448 build_int_cst (TREE_TYPE (comp), 0));
7450 gfc_add_expr_to_block (&tmpblock, tmp);
7453 if (cmp_has_alloc_comps
7455 && !called_dealloc_with_status)
7457 /* Do not deallocate the components of ultimate pointer
7458 components or iteratively call self if call has been made
7459 to gfc_trans_dealloc_allocated */
7460 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7461 decl, cdecl, NULL_TREE);
7462 rank = c->as ? c->as->rank : 0;
7463 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7465 gfc_add_expr_to_block (&fnblock, tmp);
7468 /* Now add the deallocation of this component. */
7469 gfc_add_block_to_block (&fnblock, &tmpblock);
7472 case NULLIFY_ALLOC_COMP:
7473 if (c->attr.pointer)
7475 else if (c->attr.allocatable
7476 && (c->attr.dimension|| c->attr.codimension))
7478 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7479 decl, cdecl, NULL_TREE);
7480 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7482 else if (c->attr.allocatable)
7484 /* Allocatable scalar components. */
7485 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7486 decl, cdecl, NULL_TREE);
7487 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7488 void_type_node, comp,
7489 build_int_cst (TREE_TYPE (comp), 0));
7490 gfc_add_expr_to_block (&fnblock, tmp);
7492 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7494 /* Allocatable CLASS components. */
7495 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7496 decl, cdecl, NULL_TREE);
7497 /* Add reference to '_data' component. */
7498 tmp = CLASS_DATA (c)->backend_decl;
7499 comp = fold_build3_loc (input_location, COMPONENT_REF,
7500 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7501 if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
7502 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7505 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7506 void_type_node, comp,
7507 build_int_cst (TREE_TYPE (comp), 0));
7508 gfc_add_expr_to_block (&fnblock, tmp);
7511 else if (cmp_has_alloc_comps)
7513 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7514 decl, cdecl, NULL_TREE);
7515 rank = c->as ? c->as->rank : 0;
7516 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7518 gfc_add_expr_to_block (&fnblock, tmp);
7522 case COPY_ALLOC_COMP:
7523 if (c->attr.pointer)
7526 /* We need source and destination components. */
7527 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7529 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7531 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7533 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7541 dst_data = gfc_class_data_get (dcmp);
7542 src_data = gfc_class_data_get (comp);
7543 size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
7545 if (CLASS_DATA (c)->attr.dimension)
7547 nelems = gfc_conv_descriptor_size (src_data,
7548 CLASS_DATA (c)->as->rank);
7549 src_data = gfc_conv_descriptor_data_get (src_data);
7550 dst_data = gfc_conv_descriptor_data_get (dst_data);
7553 nelems = build_int_cst (size_type_node, 1);
7555 gfc_init_block (&tmpblock);
7557 /* We need to use CALLOC as _copy might try to free allocatable
7558 components of the destination. */
7559 ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
7560 tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
7562 gfc_add_modify (&tmpblock, dst_data,
7563 fold_convert (TREE_TYPE (dst_data), tmp));
7565 tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
7566 gfc_add_expr_to_block (&tmpblock, tmp);
7567 tmp = gfc_finish_block (&tmpblock);
7569 gfc_init_block (&tmpblock);
7570 gfc_add_modify (&tmpblock, dst_data,
7571 fold_convert (TREE_TYPE (dst_data),
7572 null_pointer_node));
7573 null_data = gfc_finish_block (&tmpblock);
7575 null_cond = fold_build2_loc (input_location, NE_EXPR,
7576 boolean_type_node, src_data,
7579 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
7584 if (c->attr.allocatable && !cmp_has_alloc_comps)
7586 rank = c->as ? c->as->rank : 0;
7587 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7588 gfc_add_expr_to_block (&fnblock, tmp);
7591 if (cmp_has_alloc_comps)
7593 rank = c->as ? c->as->rank : 0;
7594 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7595 gfc_add_modify (&fnblock, dcmp, tmp);
7596 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7598 gfc_add_expr_to_block (&fnblock, tmp);
7608 return gfc_finish_block (&fnblock);
7611 /* Recursively traverse an object of derived type, generating code to
7612 nullify allocatable components. */
7615 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7617 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7618 NULLIFY_ALLOC_COMP);
7622 /* Recursively traverse an object of derived type, generating code to
7623 deallocate allocatable components. */
7626 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7628 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7629 DEALLOCATE_ALLOC_COMP);
7633 /* Recursively traverse an object of derived type, generating code to
7634 copy it and its allocatable components. */
7637 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7639 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7643 /* Recursively traverse an object of derived type, generating code to
7644 copy only its allocatable components. */
7647 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7649 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7653 /* Returns the value of LBOUND for an expression. This could be broken out
7654 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7655 called by gfc_alloc_allocatable_for_assignment. */
7657 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7662 tree cond, cond1, cond3, cond4;
7666 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7668 tmp = gfc_rank_cst[dim];
7669 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7670 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7671 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7672 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7674 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7675 stride, gfc_index_zero_node);
7676 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7677 boolean_type_node, cond3, cond1);
7678 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7679 stride, gfc_index_zero_node);
7681 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7682 tmp, build_int_cst (gfc_array_index_type,
7685 cond = boolean_false_node;
7687 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7688 boolean_type_node, cond3, cond4);
7689 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7690 boolean_type_node, cond, cond1);
7692 return fold_build3_loc (input_location, COND_EXPR,
7693 gfc_array_index_type, cond,
7694 lbound, gfc_index_one_node);
7697 if (expr->expr_type == EXPR_FUNCTION)
7699 /* A conversion function, so use the argument. */
7700 gcc_assert (expr->value.function.isym
7701 && expr->value.function.isym->conversion);
7702 expr = expr->value.function.actual->expr;
7705 if (expr->expr_type == EXPR_VARIABLE)
7707 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7708 for (ref = expr->ref; ref; ref = ref->next)
7710 if (ref->type == REF_COMPONENT
7711 && ref->u.c.component->as
7713 && ref->next->u.ar.type == AR_FULL)
7714 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7716 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7719 return gfc_index_one_node;
7723 /* Returns true if an expression represents an lhs that can be reallocated
7727 gfc_is_reallocatable_lhs (gfc_expr *expr)
7734 /* An allocatable variable. */
7735 if (expr->symtree->n.sym->attr.allocatable
7737 && expr->ref->type == REF_ARRAY
7738 && expr->ref->u.ar.type == AR_FULL)
7741 /* All that can be left are allocatable components. */
7742 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7743 && expr->symtree->n.sym->ts.type != BT_CLASS)
7744 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7747 /* Find a component ref followed by an array reference. */
7748 for (ref = expr->ref; ref; ref = ref->next)
7750 && ref->type == REF_COMPONENT
7751 && ref->next->type == REF_ARRAY
7752 && !ref->next->next)
7758 /* Return true if valid reallocatable lhs. */
7759 if (ref->u.c.component->attr.allocatable
7760 && ref->next->u.ar.type == AR_FULL)
7767 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7771 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7775 stmtblock_t realloc_block;
7776 stmtblock_t alloc_block;
7780 gfc_array_info *linfo;
7800 gfc_array_spec * as;
7802 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7803 Find the lhs expression in the loop chain and set expr1 and
7804 expr2 accordingly. */
7805 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7808 /* Find the ss for the lhs. */
7810 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7811 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
7813 if (lss == gfc_ss_terminator)
7815 expr1 = lss->info->expr;
7818 /* Bail out if this is not a valid allocate on assignment. */
7819 if (!gfc_is_reallocatable_lhs (expr1)
7820 || (expr2 && !expr2->rank))
7823 /* Find the ss for the lhs. */
7825 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7826 if (lss->info->expr == expr1)
7829 if (lss == gfc_ss_terminator)
7832 linfo = &lss->info->data.array;
7834 /* Find an ss for the rhs. For operator expressions, we see the
7835 ss's for the operands. Any one of these will do. */
7837 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7838 if (rss->info->expr != expr1 && rss != loop->temp_ss)
7841 if (expr2 && rss == gfc_ss_terminator)
7844 gfc_start_block (&fblock);
7846 /* Since the lhs is allocatable, this must be a descriptor type.
7847 Get the data and array size. */
7848 desc = linfo->descriptor;
7849 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7850 array1 = gfc_conv_descriptor_data_get (desc);
7852 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7853 deallocated if expr is an array of different shape or any of the
7854 corresponding length type parameter values of variable and expr
7855 differ." This assures F95 compatibility. */
7856 jump_label1 = gfc_build_label_decl (NULL_TREE);
7857 jump_label2 = gfc_build_label_decl (NULL_TREE);
7859 /* Allocate if data is NULL. */
7860 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7861 array1, build_int_cst (TREE_TYPE (array1), 0));
7862 tmp = build3_v (COND_EXPR, cond,
7863 build1_v (GOTO_EXPR, jump_label1),
7864 build_empty_stmt (input_location));
7865 gfc_add_expr_to_block (&fblock, tmp);
7867 /* Get arrayspec if expr is a full array. */
7868 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7869 && expr2->value.function.isym
7870 && expr2->value.function.isym->conversion)
7872 /* For conversion functions, take the arg. */
7873 gfc_expr *arg = expr2->value.function.actual->expr;
7874 as = gfc_get_full_arrayspec_from_expr (arg);
7877 as = gfc_get_full_arrayspec_from_expr (expr2);
7881 /* If the lhs shape is not the same as the rhs jump to setting the
7882 bounds and doing the reallocation....... */
7883 for (n = 0; n < expr1->rank; n++)
7885 /* Check the shape. */
7886 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7887 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7888 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7889 gfc_array_index_type,
7890 loop->to[n], loop->from[n]);
7891 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7892 gfc_array_index_type,
7894 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7895 gfc_array_index_type,
7897 cond = fold_build2_loc (input_location, NE_EXPR,
7899 tmp, gfc_index_zero_node);
7900 tmp = build3_v (COND_EXPR, cond,
7901 build1_v (GOTO_EXPR, jump_label1),
7902 build_empty_stmt (input_location));
7903 gfc_add_expr_to_block (&fblock, tmp);
7906 /* ....else jump past the (re)alloc code. */
7907 tmp = build1_v (GOTO_EXPR, jump_label2);
7908 gfc_add_expr_to_block (&fblock, tmp);
7910 /* Add the label to start automatic (re)allocation. */
7911 tmp = build1_v (LABEL_EXPR, jump_label1);
7912 gfc_add_expr_to_block (&fblock, tmp);
7914 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7916 /* Get the rhs size. Fix both sizes. */
7918 desc2 = rss->info->data.array.descriptor;
7921 size2 = gfc_index_one_node;
7922 for (n = 0; n < expr2->rank; n++)
7924 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7925 gfc_array_index_type,
7926 loop->to[n], loop->from[n]);
7927 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7928 gfc_array_index_type,
7929 tmp, gfc_index_one_node);
7930 size2 = fold_build2_loc (input_location, MULT_EXPR,
7931 gfc_array_index_type,
7935 size1 = gfc_evaluate_now (size1, &fblock);
7936 size2 = gfc_evaluate_now (size2, &fblock);
7938 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7940 neq_size = gfc_evaluate_now (cond, &fblock);
7943 /* Now modify the lhs descriptor and the associated scalarizer
7944 variables. F2003 7.4.1.3: "If variable is or becomes an
7945 unallocated allocatable variable, then it is allocated with each
7946 deferred type parameter equal to the corresponding type parameters
7947 of expr , with the shape of expr , and with each lower bound equal
7948 to the corresponding element of LBOUND(expr)."
7949 Reuse size1 to keep a dimension-by-dimension track of the
7950 stride of the new array. */
7951 size1 = gfc_index_one_node;
7952 offset = gfc_index_zero_node;
7954 for (n = 0; n < expr2->rank; n++)
7956 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7957 gfc_array_index_type,
7958 loop->to[n], loop->from[n]);
7959 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7960 gfc_array_index_type,
7961 tmp, gfc_index_one_node);
7963 lbound = gfc_index_one_node;
7968 lbd = get_std_lbound (expr2, desc2, n,
7969 as->type == AS_ASSUMED_SIZE);
7970 ubound = fold_build2_loc (input_location,
7972 gfc_array_index_type,
7974 ubound = fold_build2_loc (input_location,
7976 gfc_array_index_type,
7981 gfc_conv_descriptor_lbound_set (&fblock, desc,
7984 gfc_conv_descriptor_ubound_set (&fblock, desc,
7987 gfc_conv_descriptor_stride_set (&fblock, desc,
7990 lbound = gfc_conv_descriptor_lbound_get (desc,
7992 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7993 gfc_array_index_type,
7995 offset = fold_build2_loc (input_location, MINUS_EXPR,
7996 gfc_array_index_type,
7998 size1 = fold_build2_loc (input_location, MULT_EXPR,
7999 gfc_array_index_type,
8003 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8004 the array offset is saved and the info.offset is used for a
8005 running offset. Use the saved_offset instead. */
8006 tmp = gfc_conv_descriptor_offset (desc);
8007 gfc_add_modify (&fblock, tmp, offset);
8008 if (linfo->saved_offset
8009 && TREE_CODE (linfo->saved_offset) == VAR_DECL)
8010 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
8012 /* Now set the deltas for the lhs. */
8013 for (n = 0; n < expr1->rank; n++)
8015 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8017 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8018 gfc_array_index_type, tmp,
8020 if (linfo->delta[dim]
8021 && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
8022 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
8025 /* Get the new lhs size in bytes. */
8026 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
8028 tmp = expr2->ts.u.cl->backend_decl;
8029 gcc_assert (expr1->ts.u.cl->backend_decl);
8030 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
8031 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
8033 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
8035 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
8036 tmp = fold_build2_loc (input_location, MULT_EXPR,
8037 gfc_array_index_type, tmp,
8038 expr1->ts.u.cl->backend_decl);
8041 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
8042 tmp = fold_convert (gfc_array_index_type, tmp);
8043 size2 = fold_build2_loc (input_location, MULT_EXPR,
8044 gfc_array_index_type,
8046 size2 = fold_convert (size_type_node, size2);
8047 size2 = gfc_evaluate_now (size2, &fblock);
8049 /* Realloc expression. Note that the scalarizer uses desc.data
8050 in the array reference - (*desc.data)[<element>]. */
8051 gfc_init_block (&realloc_block);
8052 tmp = build_call_expr_loc (input_location,
8053 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
8054 fold_convert (pvoid_type_node, array1),
8056 gfc_conv_descriptor_data_set (&realloc_block,
8058 realloc_expr = gfc_finish_block (&realloc_block);
8060 /* Only reallocate if sizes are different. */
8061 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
8062 build_empty_stmt (input_location));
8066 /* Malloc expression. */
8067 gfc_init_block (&alloc_block);
8068 tmp = build_call_expr_loc (input_location,
8069 builtin_decl_explicit (BUILT_IN_MALLOC),
8071 gfc_conv_descriptor_data_set (&alloc_block,
8073 tmp = gfc_conv_descriptor_dtype (desc);
8074 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
8075 alloc_expr = gfc_finish_block (&alloc_block);
8077 /* Malloc if not allocated; realloc otherwise. */
8078 tmp = build_int_cst (TREE_TYPE (array1), 0);
8079 cond = fold_build2_loc (input_location, EQ_EXPR,
8082 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
8083 gfc_add_expr_to_block (&fblock, tmp);
8085 /* Make sure that the scalarizer data pointer is updated. */
8087 && TREE_CODE (linfo->data) == VAR_DECL)
8089 tmp = gfc_conv_descriptor_data_get (desc);
8090 gfc_add_modify (&fblock, linfo->data, tmp);
8093 /* Add the exit label. */
8094 tmp = build1_v (LABEL_EXPR, jump_label2);
8095 gfc_add_expr_to_block (&fblock, tmp);
8097 return gfc_finish_block (&fblock);
8101 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8102 Do likewise, recursively if necessary, with the allocatable components of
8106 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
8112 stmtblock_t cleanup;
8115 bool sym_has_alloc_comp;
8117 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
8118 || sym->ts.type == BT_CLASS)
8119 && sym->ts.u.derived->attr.alloc_comp;
8121 /* Make sure the frontend gets these right. */
8122 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
8123 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
8124 "allocatable attribute or derived type without allocatable "
8127 gfc_save_backend_locus (&loc);
8128 gfc_set_backend_locus (&sym->declared_at);
8129 gfc_init_block (&init);
8131 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
8132 || TREE_CODE (sym->backend_decl) == PARM_DECL);
8134 if (sym->ts.type == BT_CHARACTER
8135 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
8137 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
8138 gfc_trans_vla_type_sizes (sym, &init);
8141 /* Dummy, use associated and result variables don't need anything special. */
8142 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
8144 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8145 gfc_restore_backend_locus (&loc);
8149 descriptor = sym->backend_decl;
8151 /* Although static, derived types with default initializers and
8152 allocatable components must not be nulled wholesale; instead they
8153 are treated component by component. */
8154 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
8156 /* SAVEd variables are not freed on exit. */
8157 gfc_trans_static_array_pointer (sym);
8159 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8160 gfc_restore_backend_locus (&loc);
8164 /* Get the descriptor type. */
8165 type = TREE_TYPE (sym->backend_decl);
8167 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
8170 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
8172 if (sym->value == NULL
8173 || !gfc_has_default_initializer (sym->ts.u.derived))
8175 rank = sym->as ? sym->as->rank : 0;
8176 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
8178 gfc_add_expr_to_block (&init, tmp);
8181 gfc_init_default_dt (sym, &init, false);
8184 else if (!GFC_DESCRIPTOR_TYPE_P (type))
8186 /* If the backend_decl is not a descriptor, we must have a pointer
8188 descriptor = build_fold_indirect_ref_loc (input_location,
8190 type = TREE_TYPE (descriptor);
8193 /* NULLIFY the data pointer. */
8194 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
8195 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
8197 gfc_restore_backend_locus (&loc);
8198 gfc_init_block (&cleanup);
8200 /* Allocatable arrays need to be freed when they go out of scope.
8201 The allocatable components of pointers must not be touched. */
8202 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
8203 && !sym->attr.pointer && !sym->attr.save)
8206 rank = sym->as ? sym->as->rank : 0;
8207 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
8208 gfc_add_expr_to_block (&cleanup, tmp);
8211 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
8212 && !sym->attr.save && !sym->attr.result)
8214 tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
8215 sym->attr.codimension);
8216 gfc_add_expr_to_block (&cleanup, tmp);
8219 gfc_add_init_cleanup (block, gfc_finish_block (&init),
8220 gfc_finish_block (&cleanup));
8223 /************ Expression Walking Functions ******************/
8225 /* Walk a variable reference.
8227 Possible extension - multiple component subscripts.
8228 x(:,:) = foo%a(:)%b(:)
8230 forall (i=..., j=...)
8231 x(i,j) = foo%a(j)%b(i)
8233 This adds a fair amount of complexity because you need to deal with more
8234 than one ref. Maybe handle in a similar manner to vector subscripts.
8235 Maybe not worth the effort. */
8239 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
8243 for (ref = expr->ref; ref; ref = ref->next)
8244 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
8247 return gfc_walk_array_ref (ss, expr, ref);
8252 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
8258 for (; ref; ref = ref->next)
8260 if (ref->type == REF_SUBSTRING)
8262 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
8263 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
8266 /* We're only interested in array sections from now on. */
8267 if (ref->type != REF_ARRAY)
8275 for (n = ar->dimen - 1; n >= 0; n--)
8276 ss = gfc_get_scalar_ss (ss, ar->start[n]);
8280 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
8281 newss->info->data.array.ref = ref;
8283 /* Make sure array is the same as array(:,:), this way
8284 we don't need to special case all the time. */
8285 ar->dimen = ar->as->rank;
8286 for (n = 0; n < ar->dimen; n++)
8288 ar->dimen_type[n] = DIMEN_RANGE;
8290 gcc_assert (ar->start[n] == NULL);
8291 gcc_assert (ar->end[n] == NULL);
8292 gcc_assert (ar->stride[n] == NULL);
8298 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
8299 newss->info->data.array.ref = ref;
8301 /* We add SS chains for all the subscripts in the section. */
8302 for (n = 0; n < ar->dimen; n++)
8306 switch (ar->dimen_type[n])
8309 /* Add SS for elemental (scalar) subscripts. */
8310 gcc_assert (ar->start[n]);
8311 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
8312 indexss->loop_chain = gfc_ss_terminator;
8313 newss->info->data.array.subscript[n] = indexss;
8317 /* We don't add anything for sections, just remember this
8318 dimension for later. */
8319 newss->dim[newss->dimen] = n;
8324 /* Create a GFC_SS_VECTOR index in which we can store
8325 the vector's descriptor. */
8326 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
8328 indexss->loop_chain = gfc_ss_terminator;
8329 newss->info->data.array.subscript[n] = indexss;
8330 newss->dim[newss->dimen] = n;
8335 /* We should know what sort of section it is by now. */
8339 /* We should have at least one non-elemental dimension,
8340 unless we are creating a descriptor for a (scalar) coarray. */
8341 gcc_assert (newss->dimen > 0
8342 || newss->info->data.array.ref->u.ar.as->corank > 0);
8347 /* We should know what sort of section it is by now. */
8356 /* Walk an expression operator. If only one operand of a binary expression is
8357 scalar, we must also add the scalar term to the SS chain. */
8360 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
8365 head = gfc_walk_subexpr (ss, expr->value.op.op1);
8366 if (expr->value.op.op2 == NULL)
8369 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
8371 /* All operands are scalar. Pass back and let the caller deal with it. */
8375 /* All operands require scalarization. */
8376 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
8379 /* One of the operands needs scalarization, the other is scalar.
8380 Create a gfc_ss for the scalar expression. */
8383 /* First operand is scalar. We build the chain in reverse order, so
8384 add the scalar SS after the second operand. */
8386 while (head && head->next != ss)
8388 /* Check we haven't somehow broken the chain. */
8390 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
8392 else /* head2 == head */
8394 gcc_assert (head2 == head);
8395 /* Second operand is scalar. */
8396 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
8403 /* Reverse a SS chain. */
8406 gfc_reverse_ss (gfc_ss * ss)
8411 gcc_assert (ss != NULL);
8413 head = gfc_ss_terminator;
8414 while (ss != gfc_ss_terminator)
8417 /* Check we didn't somehow break the chain. */
8418 gcc_assert (next != NULL);
8428 /* Given an expression refering to a procedure, return the symbol of its
8429 interface. We can't get the procedure symbol directly as we have to handle
8430 the case of (deferred) type-bound procedures. */
8433 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8438 if (procedure_ref == NULL)
8441 /* Normal procedure case. */
8442 sym = procedure_ref->symtree->n.sym;
8444 /* Typebound procedure case. */
8445 for (ref = procedure_ref->ref; ref; ref = ref->next)
8447 if (ref->type == REF_COMPONENT
8448 && ref->u.c.component->attr.proc_pointer)
8449 sym = ref->u.c.component->ts.interface;
8458 /* Walk the arguments of an elemental function.
8459 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8460 it is NULL, we don't do the check and the argument is assumed to be present.
8464 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8465 gfc_symbol *proc_ifc, gfc_ss_type type)
8467 gfc_formal_arglist *dummy_arg;
8473 head = gfc_ss_terminator;
8477 dummy_arg = proc_ifc->formal;
8482 for (; arg; arg = arg->next)
8484 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
8487 newss = gfc_walk_subexpr (head, arg->expr);
8490 /* Scalar argument. */
8491 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
8492 newss = gfc_get_scalar_ss (head, arg->expr);
8493 newss->info->type = type;
8495 if (dummy_arg != NULL
8496 && dummy_arg->sym->attr.optional
8497 && arg->expr->expr_type == EXPR_VARIABLE
8498 && (gfc_expr_attr (arg->expr).optional
8499 || gfc_expr_attr (arg->expr).allocatable
8500 || gfc_expr_attr (arg->expr).pointer))
8501 newss->info->data.scalar.can_be_null_ref = true;
8510 while (tail->next != gfc_ss_terminator)
8514 if (dummy_arg != NULL)
8515 dummy_arg = dummy_arg->next;
8520 /* If all the arguments are scalar we don't need the argument SS. */
8521 gfc_free_ss_chain (head);
8526 /* Add it onto the existing chain. */
8532 /* Walk a function call. Scalar functions are passed back, and taken out of
8533 scalarization loops. For elemental functions we walk their arguments.
8534 The result of functions returning arrays is stored in a temporary outside
8535 the loop, so that the function is only called once. Hence we do not need
8536 to walk their arguments. */
8539 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
8541 gfc_intrinsic_sym *isym;
8543 gfc_component *comp = NULL;
8545 isym = expr->value.function.isym;
8547 /* Handle intrinsic functions separately. */
8549 return gfc_walk_intrinsic_function (ss, expr, isym);
8551 sym = expr->value.function.esym;
8553 sym = expr->symtree->n.sym;
8555 /* A function that returns arrays. */
8556 gfc_is_proc_ptr_comp (expr, &comp);
8557 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
8558 || (comp && comp->attr.dimension))
8559 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
8561 /* Walk the parameters of an elemental function. For now we always pass
8563 if (sym->attr.elemental || (comp && comp->attr.elemental))
8564 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8565 gfc_get_proc_ifc_for_expr (expr),
8568 /* Scalar functions are OK as these are evaluated outside the scalarization
8569 loop. Pass back and let the caller deal with it. */
8574 /* An array temporary is constructed for array constructors. */
8577 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
8579 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
8583 /* Walk an expression. Add walked expressions to the head of the SS chain.
8584 A wholly scalar expression will not be added. */
8587 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
8591 switch (expr->expr_type)
8594 head = gfc_walk_variable_expr (ss, expr);
8598 head = gfc_walk_op_expr (ss, expr);
8602 head = gfc_walk_function_expr (ss, expr);
8607 case EXPR_STRUCTURE:
8608 /* Pass back and let the caller deal with it. */
8612 head = gfc_walk_array_constructor (ss, expr);
8615 case EXPR_SUBSTRING:
8616 /* Pass back and let the caller deal with it. */
8620 internal_error ("bad expression type during walk (%d)",
8627 /* Entry point for expression walking.
8628 A return value equal to the passed chain means this is
8629 a scalar expression. It is up to the caller to take whatever action is
8630 necessary to translate these. */
8633 gfc_walk_expr (gfc_expr * expr)
8637 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
8638 return gfc_reverse_ss (res);