1 /* Array translation routines
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
80 #include "coretypes.h"
84 #include "gimple-expr.h"
86 #include "fold-const.h"
87 #include "constructor.h"
88 #include "trans-types.h"
89 #include "trans-array.h"
90 #include "trans-const.h"
91 #include "dependency.h"
93 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
95 /* The contents of this structure aren't actually used, just the address. */
96 static gfc_ss gfc_ss_terminator_var;
97 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
101 gfc_array_dataptr_type (tree desc)
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
107 /* Build expressions to access the members of an array descriptor.
108 It's surprisingly easy to mess up here, so never access
109 an array descriptor by "brute force", always use these
110 functions. This also avoids problems if we change the format
111 of an array descriptor.
113 To understand these magic numbers, look at the comments
114 before gfc_build_array_type() in trans-types.c.
116 The code within these defines should be the only code which knows the format
117 of an array descriptor.
119 Any code just needing to read obtain the bounds of an array should use
120 gfc_conv_array_* rather than the following functions as these will return
121 know constant values, and work with arrays which do not have descriptors.
123 Don't forget to #undef these! */
126 #define OFFSET_FIELD 1
127 #define DTYPE_FIELD 2
128 #define DIMENSION_FIELD 3
129 #define CAF_TOKEN_FIELD 4
131 #define STRIDE_SUBFIELD 0
132 #define LBOUND_SUBFIELD 1
133 #define UBOUND_SUBFIELD 2
135 /* This provides READ-ONLY access to the data field. The field itself
136 doesn't have the proper type. */
139 gfc_conv_descriptor_data_get (tree desc)
143 type = TREE_TYPE (desc);
144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
146 field = TYPE_FIELDS (type);
147 gcc_assert (DATA_FIELD == 0);
149 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 type = TREE_TYPE (desc);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172 field = TYPE_FIELDS (type);
173 gcc_assert (DATA_FIELD == 0);
175 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
181 /* This provides address access to the data field. This should only be
182 used by array allocation, passing this on to the runtime. */
185 gfc_conv_descriptor_data_addr (tree desc)
189 type = TREE_TYPE (desc);
190 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
192 field = TYPE_FIELDS (type);
193 gcc_assert (DATA_FIELD == 0);
195 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
197 return gfc_build_addr_expr (NULL_TREE, t);
201 gfc_conv_descriptor_offset (tree desc)
206 type = TREE_TYPE (desc);
207 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
210 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_offset_get (tree desc)
219 return gfc_conv_descriptor_offset (desc);
223 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
226 tree t = gfc_conv_descriptor_offset (desc);
227 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
232 gfc_conv_descriptor_dtype (tree desc)
237 type = TREE_TYPE (desc);
238 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
241 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
243 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
244 desc, field, NULL_TREE);
249 gfc_conv_descriptor_rank (tree desc)
254 dtype = gfc_conv_descriptor_dtype (desc);
255 tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
256 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
258 return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
263 gfc_get_descriptor_dimension (tree desc)
267 type = TREE_TYPE (desc);
268 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
270 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
271 gcc_assert (field != NULL_TREE
272 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
273 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
275 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
276 desc, field, NULL_TREE);
281 gfc_conv_descriptor_dimension (tree desc, tree dim)
285 tmp = gfc_get_descriptor_dimension (desc);
287 return gfc_build_array_ref (tmp, dim, NULL);
292 gfc_conv_descriptor_token (tree desc)
297 type = TREE_TYPE (desc);
298 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
300 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
302 /* Should be a restricted pointer - except in the finalization wrapper. */
303 gcc_assert (field != NULL_TREE
304 && (TREE_TYPE (field) == prvoid_type_node
305 || TREE_TYPE (field) == pvoid_type_node));
307 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
308 desc, field, NULL_TREE);
313 gfc_conv_descriptor_stride (tree desc, tree dim)
318 tmp = gfc_conv_descriptor_dimension (desc, dim);
319 field = TYPE_FIELDS (TREE_TYPE (tmp));
320 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
321 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
323 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
324 tmp, field, NULL_TREE);
329 gfc_conv_descriptor_stride_get (tree desc, tree dim)
331 tree type = TREE_TYPE (desc);
332 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
333 if (integer_zerop (dim)
334 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
335 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
336 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
337 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
338 return gfc_index_one_node;
340 return gfc_conv_descriptor_stride (desc, dim);
344 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
345 tree dim, tree value)
347 tree t = gfc_conv_descriptor_stride (desc, dim);
348 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
352 gfc_conv_descriptor_lbound (tree desc, tree dim)
357 tmp = gfc_conv_descriptor_dimension (desc, dim);
358 field = TYPE_FIELDS (TREE_TYPE (tmp));
359 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
360 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
362 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
363 tmp, field, NULL_TREE);
368 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
370 return gfc_conv_descriptor_lbound (desc, dim);
374 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
375 tree dim, tree value)
377 tree t = gfc_conv_descriptor_lbound (desc, dim);
378 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
382 gfc_conv_descriptor_ubound (tree desc, tree dim)
387 tmp = gfc_conv_descriptor_dimension (desc, dim);
388 field = TYPE_FIELDS (TREE_TYPE (tmp));
389 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
390 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
392 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
393 tmp, field, NULL_TREE);
398 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
400 return gfc_conv_descriptor_ubound (desc, dim);
404 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
405 tree dim, tree value)
407 tree t = gfc_conv_descriptor_ubound (desc, dim);
408 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
411 /* Build a null array descriptor constructor. */
414 gfc_build_null_descriptor (tree type)
419 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
420 gcc_assert (DATA_FIELD == 0);
421 field = TYPE_FIELDS (type);
423 /* Set a NULL data pointer. */
424 tmp = build_constructor_single (type, field, null_pointer_node);
425 TREE_CONSTANT (tmp) = 1;
426 /* All other fields are ignored. */
432 /* Modify a descriptor such that the lbound of a given dimension is the value
433 specified. This also updates ubound and offset accordingly. */
436 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
437 int dim, tree new_lbound)
439 tree offs, ubound, lbound, stride;
440 tree diff, offs_diff;
442 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
444 offs = gfc_conv_descriptor_offset_get (desc);
445 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
446 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
447 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
449 /* Get difference (new - old) by which to shift stuff. */
450 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
453 /* Shift ubound and offset accordingly. This has to be done before
454 updating the lbound, as they depend on the lbound expression! */
455 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
457 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
458 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
460 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
462 gfc_conv_descriptor_offset_set (block, desc, offs);
464 /* Finally set lbound to value we want. */
465 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
469 /* Cleanup those #defines. */
474 #undef DIMENSION_FIELD
475 #undef CAF_TOKEN_FIELD
476 #undef STRIDE_SUBFIELD
477 #undef LBOUND_SUBFIELD
478 #undef UBOUND_SUBFIELD
481 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
482 flags & 1 = Main loop body.
483 flags & 2 = temp copy loop. */
486 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
488 for (; ss != gfc_ss_terminator; ss = ss->next)
489 ss->info->useflags = flags;
493 /* Free a gfc_ss chain. */
496 gfc_free_ss_chain (gfc_ss * ss)
500 while (ss != gfc_ss_terminator)
502 gcc_assert (ss != NULL);
511 free_ss_info (gfc_ss_info *ss_info)
516 if (ss_info->refcount > 0)
519 gcc_assert (ss_info->refcount == 0);
521 switch (ss_info->type)
524 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
525 if (ss_info->data.array.subscript[n])
526 gfc_free_ss_chain (ss_info->data.array.subscript[n]);
540 gfc_free_ss (gfc_ss * ss)
542 free_ss_info (ss->info);
547 /* Creates and initializes an array type gfc_ss struct. */
550 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
553 gfc_ss_info *ss_info;
556 ss_info = gfc_get_ss_info ();
558 ss_info->type = type;
559 ss_info->expr = expr;
565 for (i = 0; i < ss->dimen; i++)
572 /* Creates and initializes a temporary type gfc_ss struct. */
575 gfc_get_temp_ss (tree type, tree string_length, int dimen)
578 gfc_ss_info *ss_info;
581 ss_info = gfc_get_ss_info ();
583 ss_info->type = GFC_SS_TEMP;
584 ss_info->string_length = string_length;
585 ss_info->data.temp.type = type;
589 ss->next = gfc_ss_terminator;
591 for (i = 0; i < ss->dimen; i++)
598 /* Creates and initializes a scalar type gfc_ss struct. */
601 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
604 gfc_ss_info *ss_info;
606 ss_info = gfc_get_ss_info ();
608 ss_info->type = GFC_SS_SCALAR;
609 ss_info->expr = expr;
619 /* Free all the SS associated with a loop. */
622 gfc_cleanup_loop (gfc_loopinfo * loop)
624 gfc_loopinfo *loop_next, **ploop;
629 while (ss != gfc_ss_terminator)
631 gcc_assert (ss != NULL);
632 next = ss->loop_chain;
637 /* Remove reference to self in the parent loop. */
639 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
646 /* Free non-freed nested loops. */
647 for (loop = loop->nested; loop; loop = loop_next)
649 loop_next = loop->next;
650 gfc_cleanup_loop (loop);
657 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
661 for (; ss != gfc_ss_terminator; ss = ss->next)
665 if (ss->info->type == GFC_SS_SCALAR
666 || ss->info->type == GFC_SS_REFERENCE
667 || ss->info->type == GFC_SS_TEMP)
670 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
671 if (ss->info->data.array.subscript[n] != NULL)
672 set_ss_loop (ss->info->data.array.subscript[n], loop);
677 /* Associate a SS chain with a loop. */
680 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
683 gfc_loopinfo *nested_loop;
685 if (head == gfc_ss_terminator)
688 set_ss_loop (head, loop);
691 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
695 nested_loop = ss->nested_ss->loop;
697 /* More than one ss can belong to the same loop. Hence, we add the
698 loop to the chain only if it is different from the previously
699 added one, to avoid duplicate nested loops. */
700 if (nested_loop != loop->nested)
702 gcc_assert (nested_loop->parent == NULL);
703 nested_loop->parent = loop;
705 gcc_assert (nested_loop->next == NULL);
706 nested_loop->next = loop->nested;
707 loop->nested = nested_loop;
710 gcc_assert (nested_loop->parent == loop);
713 if (ss->next == gfc_ss_terminator)
714 ss->loop_chain = loop->ss;
716 ss->loop_chain = ss->next;
718 gcc_assert (ss == gfc_ss_terminator);
723 /* Generate an initializer for a static pointer or allocatable array. */
726 gfc_trans_static_array_pointer (gfc_symbol * sym)
730 gcc_assert (TREE_STATIC (sym->backend_decl));
731 /* Just zero the data member. */
732 type = TREE_TYPE (sym->backend_decl);
733 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
737 /* If the bounds of SE's loop have not yet been set, see if they can be
738 determined from array spec AS, which is the array spec of a called
739 function. MAPPING maps the callee's dummy arguments to the values
740 that the caller is passing. Add any initialization and finalization
744 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
745 gfc_se * se, gfc_array_spec * as)
747 int n, dim, total_dim;
756 if (!as || as->type != AS_EXPLICIT)
759 for (ss = se->ss; ss; ss = ss->parent)
761 total_dim += ss->loop->dimen;
762 for (n = 0; n < ss->loop->dimen; n++)
764 /* The bound is known, nothing to do. */
765 if (ss->loop->to[n] != NULL_TREE)
769 gcc_assert (dim < as->rank);
770 gcc_assert (ss->loop->dimen <= as->rank);
772 /* Evaluate the lower bound. */
773 gfc_init_se (&tmpse, NULL);
774 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
775 gfc_add_block_to_block (&se->pre, &tmpse.pre);
776 gfc_add_block_to_block (&se->post, &tmpse.post);
777 lower = fold_convert (gfc_array_index_type, tmpse.expr);
779 /* ...and the upper bound. */
780 gfc_init_se (&tmpse, NULL);
781 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
782 gfc_add_block_to_block (&se->pre, &tmpse.pre);
783 gfc_add_block_to_block (&se->post, &tmpse.post);
784 upper = fold_convert (gfc_array_index_type, tmpse.expr);
786 /* Set the upper bound of the loop to UPPER - LOWER. */
787 tmp = fold_build2_loc (input_location, MINUS_EXPR,
788 gfc_array_index_type, upper, lower);
789 tmp = gfc_evaluate_now (tmp, &se->pre);
790 ss->loop->to[n] = tmp;
794 gcc_assert (total_dim == as->rank);
798 /* Generate code to allocate an array temporary, or create a variable to
799 hold the data. If size is NULL, zero the descriptor so that the
800 callee will allocate the array. If DEALLOC is true, also generate code to
801 free the array afterwards.
803 If INITIAL is not NULL, it is packed using internal_pack and the result used
804 as data instead of allocating a fresh, unitialized area of memory.
806 Initialization code is added to PRE and finalization code to POST.
807 DYNAMIC is true if the caller may want to extend the array later
808 using realloc. This prevents us from putting the array on the stack. */
811 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
812 gfc_array_info * info, tree size, tree nelem,
813 tree initial, bool dynamic, bool dealloc)
819 desc = info->descriptor;
820 info->offset = gfc_index_zero_node;
821 if (size == NULL_TREE || integer_zerop (size))
823 /* A callee allocated array. */
824 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
829 /* Allocate the temporary. */
830 onstack = !dynamic && initial == NULL_TREE
831 && (flag_stack_arrays
832 || gfc_can_put_var_on_stack (size));
836 /* Make a temporary variable to hold the data. */
837 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
838 nelem, gfc_index_one_node);
839 tmp = gfc_evaluate_now (tmp, pre);
840 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
842 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
844 tmp = gfc_create_var (tmp, "A");
845 /* If we're here only because of -fstack-arrays we have to
846 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
847 if (!gfc_can_put_var_on_stack (size))
848 gfc_add_expr_to_block (pre,
849 fold_build1_loc (input_location,
850 DECL_EXPR, TREE_TYPE (tmp),
852 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
853 gfc_conv_descriptor_data_set (pre, desc, tmp);
857 /* Allocate memory to hold the data or call internal_pack. */
858 if (initial == NULL_TREE)
860 tmp = gfc_call_malloc (pre, NULL, size);
861 tmp = gfc_evaluate_now (tmp, pre);
868 stmtblock_t do_copying;
870 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
871 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
872 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
873 tmp = gfc_get_element_type (tmp);
874 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
875 packed = gfc_create_var (build_pointer_type (tmp), "data");
877 tmp = build_call_expr_loc (input_location,
878 gfor_fndecl_in_pack, 1, initial);
879 tmp = fold_convert (TREE_TYPE (packed), tmp);
880 gfc_add_modify (pre, packed, tmp);
882 tmp = build_fold_indirect_ref_loc (input_location,
884 source_data = gfc_conv_descriptor_data_get (tmp);
886 /* internal_pack may return source->data without any allocation
887 or copying if it is already packed. If that's the case, we
888 need to allocate and copy manually. */
890 gfc_start_block (&do_copying);
891 tmp = gfc_call_malloc (&do_copying, NULL, size);
892 tmp = fold_convert (TREE_TYPE (packed), tmp);
893 gfc_add_modify (&do_copying, packed, tmp);
894 tmp = gfc_build_memcpy_call (packed, source_data, size);
895 gfc_add_expr_to_block (&do_copying, tmp);
897 was_packed = fold_build2_loc (input_location, EQ_EXPR,
898 boolean_type_node, packed,
900 tmp = gfc_finish_block (&do_copying);
901 tmp = build3_v (COND_EXPR, was_packed, tmp,
902 build_empty_stmt (input_location));
903 gfc_add_expr_to_block (pre, tmp);
905 tmp = fold_convert (pvoid_type_node, packed);
908 gfc_conv_descriptor_data_set (pre, desc, tmp);
911 info->data = gfc_conv_descriptor_data_get (desc);
913 /* The offset is zero because we create temporaries with a zero
915 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
917 if (dealloc && !onstack)
919 /* Free the temporary. */
920 tmp = gfc_conv_descriptor_data_get (desc);
921 tmp = gfc_call_free (tmp);
922 gfc_add_expr_to_block (post, tmp);
927 /* Get the scalarizer array dimension corresponding to actual array dimension
930 For example, if SS represents the array ref a(1,:,:,1), it is a
931 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
932 and 1 for ARRAY_DIM=2.
933 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
934 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
936 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
937 array. If called on the inner ss, the result would be respectively 0,1,2 for
938 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
939 for ARRAY_DIM=1,2. */
942 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
949 for (; ss; ss = ss->parent)
950 for (n = 0; n < ss->dimen; n++)
951 if (ss->dim[n] < array_dim)
954 return array_ref_dim;
959 innermost_ss (gfc_ss *ss)
961 while (ss->nested_ss != NULL)
969 /* Get the array reference dimension corresponding to the given loop dimension.
970 It is different from the true array dimension given by the dim array in
971 the case of a partial array reference (i.e. a(:,:,1,:) for example)
972 It is different from the loop dimension in the case of a transposed array.
976 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
978 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
983 /* Generate code to create and initialize the descriptor for a temporary
984 array. This is used for both temporaries needed by the scalarizer, and
985 functions returning arrays. Adjusts the loop variables to be
986 zero-based, and calculates the loop bounds for callee allocated arrays.
987 Allocate the array unless it's callee allocated (we have a callee
988 allocated array if 'callee_alloc' is true, or if loop->to[n] is
989 NULL_TREE for any n). Also fills in the descriptor, data and offset
990 fields of info if known. Returns the size of the array, or NULL for a
991 callee allocated array.
993 'eltype' == NULL signals that the temporary should be a class object.
994 The 'initial' expression is used to obtain the size of the dynamic
995 type; otherwise the allocation and initialization proceeds as for any
998 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
999 gfc_trans_allocate_array_storage. */
1002 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1003 tree eltype, tree initial, bool dynamic,
1004 bool dealloc, bool callee_alloc, locus * where)
1008 gfc_array_info *info;
1009 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1017 tree class_expr = NULL_TREE;
1018 int n, dim, tmp_dim;
1021 /* This signals a class array for which we need the size of the
1022 dynamic type. Generate an eltype and then the class expression. */
1023 if (eltype == NULL_TREE && initial)
1025 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1026 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1027 eltype = TREE_TYPE (class_expr);
1028 eltype = gfc_get_element_type (eltype);
1029 /* Obtain the structure (class) expression. */
1030 class_expr = TREE_OPERAND (class_expr, 0);
1031 gcc_assert (class_expr);
1034 memset (from, 0, sizeof (from));
1035 memset (to, 0, sizeof (to));
1037 info = &ss->info->data.array;
1039 gcc_assert (ss->dimen > 0);
1040 gcc_assert (ss->loop->dimen == ss->dimen);
1042 if (warn_array_temporaries && where)
1043 gfc_warning (OPT_Warray_temporaries,
1044 "Creating array temporary at %L", where);
1046 /* Set the lower bound to zero. */
1047 for (s = ss; s; s = s->parent)
1051 total_dim += loop->dimen;
1052 for (n = 0; n < loop->dimen; n++)
1056 /* Callee allocated arrays may not have a known bound yet. */
1058 loop->to[n] = gfc_evaluate_now (
1059 fold_build2_loc (input_location, MINUS_EXPR,
1060 gfc_array_index_type,
1061 loop->to[n], loop->from[n]),
1063 loop->from[n] = gfc_index_zero_node;
1065 /* We have just changed the loop bounds, we must clear the
1066 corresponding specloop, so that delta calculation is not skipped
1067 later in gfc_set_delta. */
1068 loop->specloop[n] = NULL;
1070 /* We are constructing the temporary's descriptor based on the loop
1071 dimensions. As the dimensions may be accessed in arbitrary order
1072 (think of transpose) the size taken from the n'th loop may not map
1073 to the n'th dimension of the array. We need to reconstruct loop
1074 infos in the right order before using it to set the descriptor
1076 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1077 from[tmp_dim] = loop->from[n];
1078 to[tmp_dim] = loop->to[n];
1080 info->delta[dim] = gfc_index_zero_node;
1081 info->start[dim] = gfc_index_zero_node;
1082 info->end[dim] = gfc_index_zero_node;
1083 info->stride[dim] = gfc_index_one_node;
1087 /* Initialize the descriptor. */
1089 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1090 GFC_ARRAY_UNKNOWN, true);
1091 desc = gfc_create_var (type, "atmp");
1092 GFC_DECL_PACKED_ARRAY (desc) = 1;
1094 info->descriptor = desc;
1095 size = gfc_index_one_node;
1097 /* Emit a DECL_EXPR for the variable sized array type in
1098 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1099 sizes works correctly. */
1100 tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1101 if (! TYPE_NAME (arraytype))
1102 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1103 NULL_TREE, arraytype);
1104 gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1105 arraytype, TYPE_NAME (arraytype)));
1107 /* Fill in the array dtype. */
1108 tmp = gfc_conv_descriptor_dtype (desc);
1109 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1112 Fill in the bounds and stride. This is a packed array, so:
1115 for (n = 0; n < rank; n++)
1118 delta = ubound[n] + 1 - lbound[n];
1119 size = size * delta;
1121 size = size * sizeof(element);
1124 or_expr = NULL_TREE;
1126 /* If there is at least one null loop->to[n], it is a callee allocated
1128 for (n = 0; n < total_dim; n++)
1129 if (to[n] == NULL_TREE)
1135 if (size == NULL_TREE)
1136 for (s = ss; s; s = s->parent)
1137 for (n = 0; n < s->loop->dimen; n++)
1139 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1141 /* For a callee allocated array express the loop bounds in terms
1142 of the descriptor fields. */
1143 tmp = fold_build2_loc (input_location,
1144 MINUS_EXPR, gfc_array_index_type,
1145 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1146 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1147 s->loop->to[n] = tmp;
1151 for (n = 0; n < total_dim; n++)
1153 /* Store the stride and bound components in the descriptor. */
1154 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1156 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1157 gfc_index_zero_node);
1159 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1161 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1162 gfc_array_index_type,
1163 to[n], gfc_index_one_node);
1165 /* Check whether the size for this dimension is negative. */
1166 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1167 tmp, gfc_index_zero_node);
1168 cond = gfc_evaluate_now (cond, pre);
1173 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1174 boolean_type_node, or_expr, cond);
1176 size = fold_build2_loc (input_location, MULT_EXPR,
1177 gfc_array_index_type, size, tmp);
1178 size = gfc_evaluate_now (size, pre);
1182 /* Get the size of the array. */
1183 if (size && !callee_alloc)
1186 /* If or_expr is true, then the extent in at least one
1187 dimension is zero and the size is set to zero. */
1188 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1189 or_expr, gfc_index_zero_node, size);
1192 if (class_expr == NULL_TREE)
1193 elemsize = fold_convert (gfc_array_index_type,
1194 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1196 elemsize = gfc_class_vtab_size_get (class_expr);
1198 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1207 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1213 if (ss->dimen > ss->loop->temp_dim)
1214 ss->loop->temp_dim = ss->dimen;
1220 /* Return the number of iterations in a loop that starts at START,
1221 ends at END, and has step STEP. */
1224 gfc_get_iteration_count (tree start, tree end, tree step)
1229 type = TREE_TYPE (step);
1230 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1231 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1232 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1233 build_int_cst (type, 1));
1234 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1235 build_int_cst (type, 0));
1236 return fold_convert (gfc_array_index_type, tmp);
1240 /* Extend the data in array DESC by EXTRA elements. */
1243 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1250 if (integer_zerop (extra))
1253 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1255 /* Add EXTRA to the upper bound. */
1256 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1258 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1260 /* Get the value of the current data pointer. */
1261 arg0 = gfc_conv_descriptor_data_get (desc);
1263 /* Calculate the new array size. */
1264 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1265 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1266 ubound, gfc_index_one_node);
1267 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1268 fold_convert (size_type_node, tmp),
1269 fold_convert (size_type_node, size));
1271 /* Call the realloc() function. */
1272 tmp = gfc_call_realloc (pblock, arg0, arg1);
1273 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1277 /* Return true if the bounds of iterator I can only be determined
1281 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1283 return (i->start->expr_type != EXPR_CONSTANT
1284 || i->end->expr_type != EXPR_CONSTANT
1285 || i->step->expr_type != EXPR_CONSTANT);
1289 /* Split the size of constructor element EXPR into the sum of two terms,
1290 one of which can be determined at compile time and one of which must
1291 be calculated at run time. Set *SIZE to the former and return true
1292 if the latter might be nonzero. */
1295 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1297 if (expr->expr_type == EXPR_ARRAY)
1298 return gfc_get_array_constructor_size (size, expr->value.constructor);
1299 else if (expr->rank > 0)
1301 /* Calculate everything at run time. */
1302 mpz_set_ui (*size, 0);
1307 /* A single element. */
1308 mpz_set_ui (*size, 1);
1314 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1315 of array constructor C. */
1318 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1326 mpz_set_ui (*size, 0);
1331 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1334 if (i && gfc_iterator_has_dynamic_bounds (i))
1338 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1341 /* Multiply the static part of the element size by the
1342 number of iterations. */
1343 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1344 mpz_fdiv_q (val, val, i->step->value.integer);
1345 mpz_add_ui (val, val, 1);
1346 if (mpz_sgn (val) > 0)
1347 mpz_mul (len, len, val);
1349 mpz_set_ui (len, 0);
1351 mpz_add (*size, *size, len);
1360 /* Make sure offset is a variable. */
1363 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1366 /* We should have already created the offset variable. We cannot
1367 create it here because we may be in an inner scope. */
1368 gcc_assert (*offsetvar != NULL_TREE);
1369 gfc_add_modify (pblock, *offsetvar, *poffset);
1370 *poffset = *offsetvar;
1371 TREE_USED (*offsetvar) = 1;
1375 /* Variables needed for bounds-checking. */
1376 static bool first_len;
1377 static tree first_len_val;
1378 static bool typespec_chararray_ctor;
1381 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1382 tree offset, gfc_se * se, gfc_expr * expr)
1386 gfc_conv_expr (se, expr);
1388 /* Store the value. */
1389 tmp = build_fold_indirect_ref_loc (input_location,
1390 gfc_conv_descriptor_data_get (desc));
1391 tmp = gfc_build_array_ref (tmp, offset, NULL);
1393 if (expr->ts.type == BT_CHARACTER)
1395 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1398 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1399 esize = fold_convert (gfc_charlen_type_node, esize);
1400 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1401 gfc_charlen_type_node, esize,
1402 build_int_cst (gfc_charlen_type_node,
1403 gfc_character_kinds[i].bit_size / 8));
1405 gfc_conv_string_parameter (se);
1406 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1408 /* The temporary is an array of pointers. */
1409 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1410 gfc_add_modify (&se->pre, tmp, se->expr);
1414 /* The temporary is an array of string values. */
1415 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1416 /* We know the temporary and the value will be the same length,
1417 so can use memcpy. */
1418 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1419 se->string_length, se->expr, expr->ts.kind);
1421 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1425 gfc_add_modify (&se->pre, first_len_val,
1431 /* Verify that all constructor elements are of the same
1433 tree cond = fold_build2_loc (input_location, NE_EXPR,
1434 boolean_type_node, first_len_val,
1436 gfc_trans_runtime_check
1437 (true, false, cond, &se->pre, &expr->where,
1438 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1439 fold_convert (long_integer_type_node, first_len_val),
1440 fold_convert (long_integer_type_node, se->string_length));
1446 /* TODO: Should the frontend already have done this conversion? */
1447 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1448 gfc_add_modify (&se->pre, tmp, se->expr);
1451 gfc_add_block_to_block (pblock, &se->pre);
1452 gfc_add_block_to_block (pblock, &se->post);
1456 /* Add the contents of an array to the constructor. DYNAMIC is as for
1457 gfc_trans_array_constructor_value. */
1460 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1461 tree type ATTRIBUTE_UNUSED,
1462 tree desc, gfc_expr * expr,
1463 tree * poffset, tree * offsetvar,
1474 /* We need this to be a variable so we can increment it. */
1475 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1477 gfc_init_se (&se, NULL);
1479 /* Walk the array expression. */
1480 ss = gfc_walk_expr (expr);
1481 gcc_assert (ss != gfc_ss_terminator);
1483 /* Initialize the scalarizer. */
1484 gfc_init_loopinfo (&loop);
1485 gfc_add_ss_to_loop (&loop, ss);
1487 /* Initialize the loop. */
1488 gfc_conv_ss_startstride (&loop);
1489 gfc_conv_loop_setup (&loop, &expr->where);
1491 /* Make sure the constructed array has room for the new data. */
1494 /* Set SIZE to the total number of elements in the subarray. */
1495 size = gfc_index_one_node;
1496 for (n = 0; n < loop.dimen; n++)
1498 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1499 gfc_index_one_node);
1500 size = fold_build2_loc (input_location, MULT_EXPR,
1501 gfc_array_index_type, size, tmp);
1504 /* Grow the constructed array by SIZE elements. */
1505 gfc_grow_array (&loop.pre, desc, size);
1508 /* Make the loop body. */
1509 gfc_mark_ss_chain_used (ss, 1);
1510 gfc_start_scalarized_body (&loop, &body);
1511 gfc_copy_loopinfo_to_se (&se, &loop);
1514 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1515 gcc_assert (se.ss == gfc_ss_terminator);
1517 /* Increment the offset. */
1518 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1519 *poffset, gfc_index_one_node);
1520 gfc_add_modify (&body, *poffset, tmp);
1522 /* Finish the loop. */
1523 gfc_trans_scalarizing_loops (&loop, &body);
1524 gfc_add_block_to_block (&loop.pre, &loop.post);
1525 tmp = gfc_finish_block (&loop.pre);
1526 gfc_add_expr_to_block (pblock, tmp);
1528 gfc_cleanup_loop (&loop);
1532 /* Assign the values to the elements of an array constructor. DYNAMIC
1533 is true if descriptor DESC only contains enough data for the static
1534 size calculated by gfc_get_array_constructor_size. When true, memory
1535 for the dynamic parts must be allocated using realloc. */
1538 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1539 tree desc, gfc_constructor_base base,
1540 tree * poffset, tree * offsetvar,
1544 tree start = NULL_TREE;
1545 tree end = NULL_TREE;
1546 tree step = NULL_TREE;
1552 tree shadow_loopvar = NULL_TREE;
1553 gfc_saved_var saved_loopvar;
1556 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1558 /* If this is an iterator or an array, the offset must be a variable. */
1559 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1560 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1562 /* Shadowing the iterator avoids changing its value and saves us from
1563 keeping track of it. Further, it makes sure that there's always a
1564 backend-decl for the symbol, even if there wasn't one before,
1565 e.g. in the case of an iterator that appears in a specification
1566 expression in an interface mapping. */
1572 /* Evaluate loop bounds before substituting the loop variable
1573 in case they depend on it. Such a case is invalid, but it is
1574 not more expensive to do the right thing here.
1576 gfc_init_se (&se, NULL);
1577 gfc_conv_expr_val (&se, c->iterator->start);
1578 gfc_add_block_to_block (pblock, &se.pre);
1579 start = gfc_evaluate_now (se.expr, pblock);
1581 gfc_init_se (&se, NULL);
1582 gfc_conv_expr_val (&se, c->iterator->end);
1583 gfc_add_block_to_block (pblock, &se.pre);
1584 end = gfc_evaluate_now (se.expr, pblock);
1586 gfc_init_se (&se, NULL);
1587 gfc_conv_expr_val (&se, c->iterator->step);
1588 gfc_add_block_to_block (pblock, &se.pre);
1589 step = gfc_evaluate_now (se.expr, pblock);
1591 sym = c->iterator->var->symtree->n.sym;
1592 type = gfc_typenode_for_spec (&sym->ts);
1594 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1595 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1598 gfc_start_block (&body);
1600 if (c->expr->expr_type == EXPR_ARRAY)
1602 /* Array constructors can be nested. */
1603 gfc_trans_array_constructor_value (&body, type, desc,
1604 c->expr->value.constructor,
1605 poffset, offsetvar, dynamic);
1607 else if (c->expr->rank > 0)
1609 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1610 poffset, offsetvar, dynamic);
1614 /* This code really upsets the gimplifier so don't bother for now. */
1621 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1623 p = gfc_constructor_next (p);
1628 /* Scalar values. */
1629 gfc_init_se (&se, NULL);
1630 gfc_trans_array_ctor_element (&body, desc, *poffset,
1633 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1634 gfc_array_index_type,
1635 *poffset, gfc_index_one_node);
1639 /* Collect multiple scalar constants into a constructor. */
1640 vec<constructor_elt, va_gc> *v = NULL;
1644 HOST_WIDE_INT idx = 0;
1647 /* Count the number of consecutive scalar constants. */
1648 while (p && !(p->iterator
1649 || p->expr->expr_type != EXPR_CONSTANT))
1651 gfc_init_se (&se, NULL);
1652 gfc_conv_constant (&se, p->expr);
1654 if (c->expr->ts.type != BT_CHARACTER)
1655 se.expr = fold_convert (type, se.expr);
1656 /* For constant character array constructors we build
1657 an array of pointers. */
1658 else if (POINTER_TYPE_P (type))
1659 se.expr = gfc_build_addr_expr
1660 (gfc_get_pchar_type (p->expr->ts.kind),
1663 CONSTRUCTOR_APPEND_ELT (v,
1664 build_int_cst (gfc_array_index_type,
1668 p = gfc_constructor_next (p);
1671 bound = size_int (n - 1);
1672 /* Create an array type to hold them. */
1673 tmptype = build_range_type (gfc_array_index_type,
1674 gfc_index_zero_node, bound);
1675 tmptype = build_array_type (type, tmptype);
1677 init = build_constructor (tmptype, v);
1678 TREE_CONSTANT (init) = 1;
1679 TREE_STATIC (init) = 1;
1680 /* Create a static variable to hold the data. */
1681 tmp = gfc_create_var (tmptype, "data");
1682 TREE_STATIC (tmp) = 1;
1683 TREE_CONSTANT (tmp) = 1;
1684 TREE_READONLY (tmp) = 1;
1685 DECL_INITIAL (tmp) = init;
1688 /* Use BUILTIN_MEMCPY to assign the values. */
1689 tmp = gfc_conv_descriptor_data_get (desc);
1690 tmp = build_fold_indirect_ref_loc (input_location,
1692 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1693 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1694 init = gfc_build_addr_expr (NULL_TREE, init);
1696 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1697 bound = build_int_cst (size_type_node, n * size);
1698 tmp = build_call_expr_loc (input_location,
1699 builtin_decl_explicit (BUILT_IN_MEMCPY),
1700 3, tmp, init, bound);
1701 gfc_add_expr_to_block (&body, tmp);
1703 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1704 gfc_array_index_type, *poffset,
1705 build_int_cst (gfc_array_index_type, n));
1707 if (!INTEGER_CST_P (*poffset))
1709 gfc_add_modify (&body, *offsetvar, *poffset);
1710 *poffset = *offsetvar;
1714 /* The frontend should already have done any expansions
1718 /* Pass the code as is. */
1719 tmp = gfc_finish_block (&body);
1720 gfc_add_expr_to_block (pblock, tmp);
1724 /* Build the implied do-loop. */
1725 stmtblock_t implied_do_block;
1731 loopbody = gfc_finish_block (&body);
1733 /* Create a new block that holds the implied-do loop. A temporary
1734 loop-variable is used. */
1735 gfc_start_block(&implied_do_block);
1737 /* Initialize the loop. */
1738 gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1740 /* If this array expands dynamically, and the number of iterations
1741 is not constant, we won't have allocated space for the static
1742 part of C->EXPR's size. Do that now. */
1743 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1745 /* Get the number of iterations. */
1746 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1748 /* Get the static part of C->EXPR's size. */
1749 gfc_get_array_constructor_element_size (&size, c->expr);
1750 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1752 /* Grow the array by TMP * TMP2 elements. */
1753 tmp = fold_build2_loc (input_location, MULT_EXPR,
1754 gfc_array_index_type, tmp, tmp2);
1755 gfc_grow_array (&implied_do_block, desc, tmp);
1758 /* Generate the loop body. */
1759 exit_label = gfc_build_label_decl (NULL_TREE);
1760 gfc_start_block (&body);
1762 /* Generate the exit condition. Depending on the sign of
1763 the step variable we have to generate the correct
1765 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1766 step, build_int_cst (TREE_TYPE (step), 0));
1767 cond = fold_build3_loc (input_location, COND_EXPR,
1768 boolean_type_node, tmp,
1769 fold_build2_loc (input_location, GT_EXPR,
1770 boolean_type_node, shadow_loopvar, end),
1771 fold_build2_loc (input_location, LT_EXPR,
1772 boolean_type_node, shadow_loopvar, end));
1773 tmp = build1_v (GOTO_EXPR, exit_label);
1774 TREE_USED (exit_label) = 1;
1775 tmp = build3_v (COND_EXPR, cond, tmp,
1776 build_empty_stmt (input_location));
1777 gfc_add_expr_to_block (&body, tmp);
1779 /* The main loop body. */
1780 gfc_add_expr_to_block (&body, loopbody);
1782 /* Increase loop variable by step. */
1783 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1784 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1786 gfc_add_modify (&body, shadow_loopvar, tmp);
1788 /* Finish the loop. */
1789 tmp = gfc_finish_block (&body);
1790 tmp = build1_v (LOOP_EXPR, tmp);
1791 gfc_add_expr_to_block (&implied_do_block, tmp);
1793 /* Add the exit label. */
1794 tmp = build1_v (LABEL_EXPR, exit_label);
1795 gfc_add_expr_to_block (&implied_do_block, tmp);
1797 /* Finish the implied-do loop. */
1798 tmp = gfc_finish_block(&implied_do_block);
1799 gfc_add_expr_to_block(pblock, tmp);
1801 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1808 /* The array constructor code can create a string length with an operand
1809 in the form of a temporary variable. This variable will retain its
1810 context (current_function_decl). If we store this length tree in a
1811 gfc_charlen structure which is shared by a variable in another
1812 context, the resulting gfc_charlen structure with a variable in a
1813 different context, we could trip the assertion in expand_expr_real_1
1814 when it sees that a variable has been created in one context and
1815 referenced in another.
1817 If this might be the case, we create a new gfc_charlen structure and
1818 link it into the current namespace. */
1821 store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
1825 gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
1828 (*clp)->backend_decl = len;
1831 /* A catch-all to obtain the string length for anything that is not
1832 a substring of non-constant length, a constant, array or variable. */
1835 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1839 /* Don't bother if we already know the length is a constant. */
1840 if (*len && INTEGER_CST_P (*len))
1843 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1844 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1847 gfc_conv_const_charlen (e->ts.u.cl);
1848 *len = e->ts.u.cl->backend_decl;
1852 /* Otherwise, be brutal even if inefficient. */
1853 gfc_init_se (&se, NULL);
1855 /* No function call, in case of side effects. */
1856 se.no_function_call = 1;
1858 gfc_conv_expr (&se, e);
1860 gfc_conv_expr_descriptor (&se, e);
1862 /* Fix the value. */
1863 *len = gfc_evaluate_now (se.string_length, &se.pre);
1865 gfc_add_block_to_block (block, &se.pre);
1866 gfc_add_block_to_block (block, &se.post);
1868 store_backend_decl (&e->ts.u.cl, *len, true);
1873 /* Figure out the string length of a variable reference expression.
1874 Used by get_array_ctor_strlen. */
1877 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1883 /* Don't bother if we already know the length is a constant. */
1884 if (*len && INTEGER_CST_P (*len))
1887 ts = &expr->symtree->n.sym->ts;
1888 for (ref = expr->ref; ref; ref = ref->next)
1893 /* Array references don't change the string length. */
1897 /* Use the length of the component. */
1898 ts = &ref->u.c.component->ts;
1902 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1903 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1905 /* Note that this might evaluate expr. */
1906 get_array_ctor_all_strlen (block, expr, len);
1909 mpz_init_set_ui (char_len, 1);
1910 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1911 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1912 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1913 *len = convert (gfc_charlen_type_node, *len);
1914 mpz_clear (char_len);
1922 *len = ts->u.cl->backend_decl;
1926 /* Figure out the string length of a character array constructor.
1927 If len is NULL, don't calculate the length; this happens for recursive calls
1928 when a sub-array-constructor is an element but not at the first position,
1929 so when we're not interested in the length.
1930 Returns TRUE if all elements are character constants. */
1933 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1940 if (gfc_constructor_first (base) == NULL)
1943 *len = build_int_cstu (gfc_charlen_type_node, 0);
1947 /* Loop over all constructor elements to find out is_const, but in len we
1948 want to store the length of the first, not the last, element. We can
1949 of course exit the loop as soon as is_const is found to be false. */
1950 for (c = gfc_constructor_first (base);
1951 c && is_const; c = gfc_constructor_next (c))
1953 switch (c->expr->expr_type)
1956 if (len && !(*len && INTEGER_CST_P (*len)))
1957 *len = build_int_cstu (gfc_charlen_type_node,
1958 c->expr->value.character.length);
1962 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1969 get_array_ctor_var_strlen (block, c->expr, len);
1975 get_array_ctor_all_strlen (block, c->expr, len);
1979 /* After the first iteration, we don't want the length modified. */
1986 /* Check whether the array constructor C consists entirely of constant
1987 elements, and if so returns the number of those elements, otherwise
1988 return zero. Note, an empty or NULL array constructor returns zero. */
1990 unsigned HOST_WIDE_INT
1991 gfc_constant_array_constructor_p (gfc_constructor_base base)
1993 unsigned HOST_WIDE_INT nelem = 0;
1995 gfc_constructor *c = gfc_constructor_first (base);
1999 || c->expr->rank > 0
2000 || c->expr->expr_type != EXPR_CONSTANT)
2002 c = gfc_constructor_next (c);
2009 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2010 and the tree type of it's elements, TYPE, return a static constant
2011 variable that is compile-time initialized. */
2014 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2016 tree tmptype, init, tmp;
2017 HOST_WIDE_INT nelem;
2022 vec<constructor_elt, va_gc> *v = NULL;
2024 /* First traverse the constructor list, converting the constants
2025 to tree to build an initializer. */
2027 c = gfc_constructor_first (expr->value.constructor);
2030 gfc_init_se (&se, NULL);
2031 gfc_conv_constant (&se, c->expr);
2032 if (c->expr->ts.type != BT_CHARACTER)
2033 se.expr = fold_convert (type, se.expr);
2034 else if (POINTER_TYPE_P (type))
2035 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2037 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2039 c = gfc_constructor_next (c);
2043 /* Next determine the tree type for the array. We use the gfortran
2044 front-end's gfc_get_nodesc_array_type in order to create a suitable
2045 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2047 memset (&as, 0, sizeof (gfc_array_spec));
2049 as.rank = expr->rank;
2050 as.type = AS_EXPLICIT;
2053 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2054 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2058 for (i = 0; i < expr->rank; i++)
2060 int tmp = (int) mpz_get_si (expr->shape[i]);
2061 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2062 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2066 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2068 /* as is not needed anymore. */
2069 for (i = 0; i < as.rank + as.corank; i++)
2071 gfc_free_expr (as.lower[i]);
2072 gfc_free_expr (as.upper[i]);
2075 init = build_constructor (tmptype, v);
2077 TREE_CONSTANT (init) = 1;
2078 TREE_STATIC (init) = 1;
2080 tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2082 DECL_ARTIFICIAL (tmp) = 1;
2083 DECL_IGNORED_P (tmp) = 1;
2084 TREE_STATIC (tmp) = 1;
2085 TREE_CONSTANT (tmp) = 1;
2086 TREE_READONLY (tmp) = 1;
2087 DECL_INITIAL (tmp) = init;
2094 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2095 This mostly initializes the scalarizer state info structure with the
2096 appropriate values to directly use the array created by the function
2097 gfc_build_constant_array_constructor. */
2100 trans_constant_array_constructor (gfc_ss * ss, tree type)
2102 gfc_array_info *info;
2106 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2108 info = &ss->info->data.array;
2110 info->descriptor = tmp;
2111 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2112 info->offset = gfc_index_zero_node;
2114 for (i = 0; i < ss->dimen; i++)
2116 info->delta[i] = gfc_index_zero_node;
2117 info->start[i] = gfc_index_zero_node;
2118 info->end[i] = gfc_index_zero_node;
2119 info->stride[i] = gfc_index_one_node;
2125 get_rank (gfc_loopinfo *loop)
2130 for (; loop; loop = loop->parent)
2131 rank += loop->dimen;
2137 /* Helper routine of gfc_trans_array_constructor to determine if the
2138 bounds of the loop specified by LOOP are constant and simple enough
2139 to use with trans_constant_array_constructor. Returns the
2140 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2143 constant_array_constructor_loop_size (gfc_loopinfo * l)
2146 tree size = gfc_index_one_node;
2150 total_dim = get_rank (l);
2152 for (loop = l; loop; loop = loop->parent)
2154 for (i = 0; i < loop->dimen; i++)
2156 /* If the bounds aren't constant, return NULL_TREE. */
2157 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2159 if (!integer_zerop (loop->from[i]))
2161 /* Only allow nonzero "from" in one-dimensional arrays. */
2164 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2165 gfc_array_index_type,
2166 loop->to[i], loop->from[i]);
2170 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2171 gfc_array_index_type, tmp, gfc_index_one_node);
2172 size = fold_build2_loc (input_location, MULT_EXPR,
2173 gfc_array_index_type, size, tmp);
2182 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2187 gcc_assert (array->nested_ss == NULL);
2189 for (ss = array; ss; ss = ss->parent)
2190 for (n = 0; n < ss->loop->dimen; n++)
2191 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2192 return &(ss->loop->to[n]);
2198 static gfc_loopinfo *
2199 outermost_loop (gfc_loopinfo * loop)
2201 while (loop->parent != NULL)
2202 loop = loop->parent;
2208 /* Array constructors are handled by constructing a temporary, then using that
2209 within the scalarization loop. This is not optimal, but seems by far the
2213 trans_array_constructor (gfc_ss * ss, locus * where)
2215 gfc_constructor_base c;
2223 bool old_first_len, old_typespec_chararray_ctor;
2224 tree old_first_len_val;
2225 gfc_loopinfo *loop, *outer_loop;
2226 gfc_ss_info *ss_info;
2232 /* Save the old values for nested checking. */
2233 old_first_len = first_len;
2234 old_first_len_val = first_len_val;
2235 old_typespec_chararray_ctor = typespec_chararray_ctor;
2238 outer_loop = outermost_loop (loop);
2240 expr = ss_info->expr;
2242 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2243 typespec was given for the array constructor. */
2244 typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2246 && expr->ts.u.cl->length_from_typespec);
2248 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2249 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2251 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2255 gcc_assert (ss->dimen == ss->loop->dimen);
2257 c = expr->value.constructor;
2258 if (expr->ts.type == BT_CHARACTER)
2261 bool force_new_cl = false;
2263 /* get_array_ctor_strlen walks the elements of the constructor, if a
2264 typespec was given, we already know the string length and want the one
2266 if (typespec_chararray_ctor && expr->ts.u.cl->length
2267 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2271 const_string = false;
2272 gfc_init_se (&length_se, NULL);
2273 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2274 gfc_charlen_type_node);
2275 ss_info->string_length = length_se.expr;
2277 /* Check if the character length is negative. If it is, then
2279 neg_len = fold_build2_loc (input_location, LT_EXPR,
2280 boolean_type_node, ss_info->string_length,
2281 build_int_cst (gfc_charlen_type_node, 0));
2282 /* Print a warning if bounds checking is enabled. */
2283 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2285 msg = xasprintf ("Negative character length treated as LEN = 0");
2286 gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2291 ss_info->string_length
2292 = fold_build3_loc (input_location, COND_EXPR,
2293 gfc_charlen_type_node, neg_len,
2294 build_int_cst (gfc_charlen_type_node, 0),
2295 ss_info->string_length);
2296 ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2299 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2300 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2304 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2305 &ss_info->string_length);
2306 force_new_cl = true;
2309 /* Complex character array constructors should have been taken care of
2310 and not end up here. */
2311 gcc_assert (ss_info->string_length);
2313 store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2315 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2317 type = build_pointer_type (type);
2320 type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2321 ? &CLASS_DATA (expr)->ts : &expr->ts);
2323 /* See if the constructor determines the loop bounds. */
2326 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2328 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2330 /* We have a multidimensional parameter. */
2331 for (s = ss; s; s = s->parent)
2334 for (n = 0; n < s->loop->dimen; n++)
2336 s->loop->from[n] = gfc_index_zero_node;
2337 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2338 gfc_index_integer_kind);
2339 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2340 gfc_array_index_type,
2342 gfc_index_one_node);
2347 if (*loop_ubound0 == NULL_TREE)
2351 /* We should have a 1-dimensional, zero-based loop. */
2352 gcc_assert (loop->parent == NULL && loop->nested == NULL);
2353 gcc_assert (loop->dimen == 1);
2354 gcc_assert (integer_zerop (loop->from[0]));
2356 /* Split the constructor size into a static part and a dynamic part.
2357 Allocate the static size up-front and record whether the dynamic
2358 size might be nonzero. */
2360 dynamic = gfc_get_array_constructor_size (&size, c);
2361 mpz_sub_ui (size, size, 1);
2362 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2366 /* Special case constant array constructors. */
2369 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2372 tree size = constant_array_constructor_loop_size (loop);
2373 if (size && compare_tree_int (size, nelem) == 0)
2375 trans_constant_array_constructor (ss, type);
2381 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2382 NULL_TREE, dynamic, true, false, where);
2384 desc = ss_info->data.array.descriptor;
2385 offset = gfc_index_zero_node;
2386 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2387 TREE_NO_WARNING (offsetvar) = 1;
2388 TREE_USED (offsetvar) = 0;
2389 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
2390 &offset, &offsetvar, dynamic);
2392 /* If the array grows dynamically, the upper bound of the loop variable
2393 is determined by the array's final upper bound. */
2396 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2397 gfc_array_index_type,
2398 offsetvar, gfc_index_one_node);
2399 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2400 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2401 if (*loop_ubound0 && VAR_P (*loop_ubound0))
2402 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2404 *loop_ubound0 = tmp;
2407 if (TREE_USED (offsetvar))
2408 pushdecl (offsetvar);
2410 gcc_assert (INTEGER_CST_P (offset));
2413 /* Disable bound checking for now because it's probably broken. */
2414 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2421 /* Restore old values of globals. */
2422 first_len = old_first_len;
2423 first_len_val = old_first_len_val;
2424 typespec_chararray_ctor = old_typespec_chararray_ctor;
2428 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2429 called after evaluating all of INFO's vector dimensions. Go through
2430 each such vector dimension and see if we can now fill in any missing
2434 set_vector_loop_bounds (gfc_ss * ss)
2436 gfc_loopinfo *loop, *outer_loop;
2437 gfc_array_info *info;
2445 outer_loop = outermost_loop (ss->loop);
2447 info = &ss->info->data.array;
2449 for (; ss; ss = ss->parent)
2453 for (n = 0; n < loop->dimen; n++)
2456 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2457 || loop->to[n] != NULL)
2460 /* Loop variable N indexes vector dimension DIM, and we don't
2461 yet know the upper bound of loop variable N. Set it to the
2462 difference between the vector's upper and lower bounds. */
2463 gcc_assert (loop->from[n] == gfc_index_zero_node);
2464 gcc_assert (info->subscript[dim]
2465 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2467 gfc_init_se (&se, NULL);
2468 desc = info->subscript[dim]->info->data.array.descriptor;
2469 zero = gfc_rank_cst[0];
2470 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2471 gfc_array_index_type,
2472 gfc_conv_descriptor_ubound_get (desc, zero),
2473 gfc_conv_descriptor_lbound_get (desc, zero));
2474 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2481 /* Tells whether a scalar argument to an elemental procedure is saved out
2482 of a scalarization loop as a value or as a reference. */
2485 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
2487 if (ss_info->type != GFC_SS_REFERENCE)
2490 /* If the actual argument can be absent (in other words, it can
2491 be a NULL reference), don't try to evaluate it; pass instead
2492 the reference directly. */
2493 if (ss_info->can_be_null_ref)
2496 /* If the expression is of polymorphic type, it's actual size is not known,
2497 so we avoid copying it anywhere. */
2498 if (ss_info->data.scalar.dummy_arg
2499 && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS
2500 && ss_info->expr->ts.type == BT_CLASS)
2503 /* If the expression is a data reference of aggregate type,
2504 and the data reference is not used on the left hand side,
2505 avoid a copy by saving a reference to the content. */
2506 if (!ss_info->data.scalar.needs_temporary
2507 && (ss_info->expr->ts.type == BT_DERIVED
2508 || ss_info->expr->ts.type == BT_CLASS)
2509 && gfc_expr_is_variable (ss_info->expr))
2512 /* Otherwise the expression is evaluated to a temporary variable before the
2513 scalarization loop. */
2518 /* Add the pre and post chains for all the scalar expressions in a SS chain
2519 to loop. This is called after the loop parameters have been calculated,
2520 but before the actual scalarizing loops. */
2523 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2526 gfc_loopinfo *nested_loop, *outer_loop;
2528 gfc_ss_info *ss_info;
2529 gfc_array_info *info;
2533 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2534 arguments could get evaluated multiple times. */
2535 if (ss->is_alloc_lhs)
2538 outer_loop = outermost_loop (loop);
2540 /* TODO: This can generate bad code if there are ordering dependencies,
2541 e.g., a callee allocated function and an unknown size constructor. */
2542 gcc_assert (ss != NULL);
2544 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2548 /* Cross loop arrays are handled from within the most nested loop. */
2549 if (ss->nested_ss != NULL)
2553 expr = ss_info->expr;
2554 info = &ss_info->data.array;
2556 switch (ss_info->type)
2559 /* Scalar expression. Evaluate this now. This includes elemental
2560 dimension indices, but not array section bounds. */
2561 gfc_init_se (&se, NULL);
2562 gfc_conv_expr (&se, expr);
2563 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2565 if (expr->ts.type != BT_CHARACTER
2566 && !gfc_is_alloc_class_scalar_function (expr))
2568 /* Move the evaluation of scalar expressions outside the
2569 scalarization loop, except for WHERE assignments. */
2571 se.expr = convert(gfc_array_index_type, se.expr);
2572 if (!ss_info->where)
2573 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2574 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2577 gfc_add_block_to_block (&outer_loop->post, &se.post);
2579 ss_info->data.scalar.value = se.expr;
2580 ss_info->string_length = se.string_length;
2583 case GFC_SS_REFERENCE:
2584 /* Scalar argument to elemental procedure. */
2585 gfc_init_se (&se, NULL);
2586 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
2587 gfc_conv_expr_reference (&se, expr);
2590 /* Evaluate the argument outside the loop and pass
2591 a reference to the value. */
2592 gfc_conv_expr (&se, expr);
2595 /* Ensure that a pointer to the string is stored. */
2596 if (expr->ts.type == BT_CHARACTER)
2597 gfc_conv_string_parameter (&se);
2599 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2600 gfc_add_block_to_block (&outer_loop->post, &se.post);
2601 if (gfc_is_class_scalar_expr (expr))
2602 /* This is necessary because the dynamic type will always be
2603 large than the declared type. In consequence, assigning
2604 the value to a temporary could segfault.
2605 OOP-TODO: see if this is generally correct or is the value
2606 has to be written to an allocated temporary, whose address
2607 is passed via ss_info. */
2608 ss_info->data.scalar.value = se.expr;
2610 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2613 ss_info->string_length = se.string_length;
2616 case GFC_SS_SECTION:
2617 /* Add the expressions for scalar and vector subscripts. */
2618 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2619 if (info->subscript[n])
2620 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2622 set_vector_loop_bounds (ss);
2626 /* Get the vector's descriptor and store it in SS. */
2627 gfc_init_se (&se, NULL);
2628 gfc_conv_expr_descriptor (&se, expr);
2629 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2630 gfc_add_block_to_block (&outer_loop->post, &se.post);
2631 info->descriptor = se.expr;
2634 case GFC_SS_INTRINSIC:
2635 gfc_add_intrinsic_ss_code (loop, ss);
2638 case GFC_SS_FUNCTION:
2639 /* Array function return value. We call the function and save its
2640 result in a temporary for use inside the loop. */
2641 gfc_init_se (&se, NULL);
2644 gfc_conv_expr (&se, expr);
2645 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2646 gfc_add_block_to_block (&outer_loop->post, &se.post);
2647 ss_info->string_length = se.string_length;
2650 case GFC_SS_CONSTRUCTOR:
2651 if (expr->ts.type == BT_CHARACTER
2652 && ss_info->string_length == NULL
2654 && expr->ts.u.cl->length
2655 && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2657 gfc_init_se (&se, NULL);
2658 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2659 gfc_charlen_type_node);
2660 ss_info->string_length = se.expr;
2661 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2662 gfc_add_block_to_block (&outer_loop->post, &se.post);
2664 trans_array_constructor (ss, where);
2668 case GFC_SS_COMPONENT:
2669 /* Do nothing. These are handled elsewhere. */
2678 for (nested_loop = loop->nested; nested_loop;
2679 nested_loop = nested_loop->next)
2680 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2684 /* Translate expressions for the descriptor and data pointer of a SS. */
2688 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2691 gfc_ss_info *ss_info;
2692 gfc_array_info *info;
2696 info = &ss_info->data.array;
2698 /* Get the descriptor for the array to be scalarized. */
2699 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2700 gfc_init_se (&se, NULL);
2701 se.descriptor_only = 1;
2702 gfc_conv_expr_lhs (&se, ss_info->expr);
2703 gfc_add_block_to_block (block, &se.pre);
2704 info->descriptor = se.expr;
2705 ss_info->string_length = se.string_length;
2709 if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
2710 && ss_info->expr->ts.u.cl->length == NULL)
2712 /* Emit a DECL_EXPR for the variable sized array type in
2713 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
2714 sizes works correctly. */
2715 tree arraytype = TREE_TYPE (
2716 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
2717 if (! TYPE_NAME (arraytype))
2718 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
2719 NULL_TREE, arraytype);
2720 gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
2721 TYPE_NAME (arraytype)));
2723 /* Also the data pointer. */
2724 tmp = gfc_conv_array_data (se.expr);
2725 /* If this is a variable or address of a variable we use it directly.
2726 Otherwise we must evaluate it now to avoid breaking dependency
2727 analysis by pulling the expressions for elemental array indices
2730 || (TREE_CODE (tmp) == ADDR_EXPR
2731 && DECL_P (TREE_OPERAND (tmp, 0)))))
2732 tmp = gfc_evaluate_now (tmp, block);
2735 tmp = gfc_conv_array_offset (se.expr);
2736 info->offset = gfc_evaluate_now (tmp, block);
2738 /* Make absolutely sure that the saved_offset is indeed saved
2739 so that the variable is still accessible after the loops
2741 info->saved_offset = info->offset;
2746 /* Initialize a gfc_loopinfo structure. */
2749 gfc_init_loopinfo (gfc_loopinfo * loop)
2753 memset (loop, 0, sizeof (gfc_loopinfo));
2754 gfc_init_block (&loop->pre);
2755 gfc_init_block (&loop->post);
2757 /* Initially scalarize in order and default to no loop reversal. */
2758 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2761 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2764 loop->ss = gfc_ss_terminator;
2768 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2772 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2778 /* Return an expression for the data pointer of an array. */
2781 gfc_conv_array_data (tree descriptor)
2785 type = TREE_TYPE (descriptor);
2786 if (GFC_ARRAY_TYPE_P (type))
2788 if (TREE_CODE (type) == POINTER_TYPE)
2792 /* Descriptorless arrays. */
2793 return gfc_build_addr_expr (NULL_TREE, descriptor);
2797 return gfc_conv_descriptor_data_get (descriptor);
2801 /* Return an expression for the base offset of an array. */
2804 gfc_conv_array_offset (tree descriptor)
2808 type = TREE_TYPE (descriptor);
2809 if (GFC_ARRAY_TYPE_P (type))
2810 return GFC_TYPE_ARRAY_OFFSET (type);
2812 return gfc_conv_descriptor_offset_get (descriptor);
2816 /* Get an expression for the array stride. */
2819 gfc_conv_array_stride (tree descriptor, int dim)
2824 type = TREE_TYPE (descriptor);
2826 /* For descriptorless arrays use the array size. */
2827 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2828 if (tmp != NULL_TREE)
2831 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2836 /* Like gfc_conv_array_stride, but for the lower bound. */
2839 gfc_conv_array_lbound (tree descriptor, int dim)
2844 type = TREE_TYPE (descriptor);
2846 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2847 if (tmp != NULL_TREE)
2850 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2855 /* Like gfc_conv_array_stride, but for the upper bound. */
2858 gfc_conv_array_ubound (tree descriptor, int dim)
2863 type = TREE_TYPE (descriptor);
2865 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2866 if (tmp != NULL_TREE)
2869 /* This should only ever happen when passing an assumed shape array
2870 as an actual parameter. The value will never be used. */
2871 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2872 return gfc_index_zero_node;
2874 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2879 /* Generate code to perform an array index bound check. */
2882 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2883 locus * where, bool check_upper)
2886 tree tmp_lo, tmp_up;
2889 const char * name = NULL;
2891 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2894 descriptor = ss->info->data.array.descriptor;
2896 index = gfc_evaluate_now (index, &se->pre);
2898 /* We find a name for the error message. */
2899 name = ss->info->expr->symtree->n.sym->name;
2900 gcc_assert (name != NULL);
2902 if (VAR_P (descriptor))
2903 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2905 /* If upper bound is present, include both bounds in the error message. */
2908 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2909 tmp_up = gfc_conv_array_ubound (descriptor, n);
2912 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2913 "outside of expected range (%%ld:%%ld)", n+1, name);
2915 msg = xasprintf ("Index '%%ld' of dimension %d "
2916 "outside of expected range (%%ld:%%ld)", n+1);
2918 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2920 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2921 fold_convert (long_integer_type_node, index),
2922 fold_convert (long_integer_type_node, tmp_lo),
2923 fold_convert (long_integer_type_node, tmp_up));
2924 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2926 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2927 fold_convert (long_integer_type_node, index),
2928 fold_convert (long_integer_type_node, tmp_lo),
2929 fold_convert (long_integer_type_node, tmp_up));
2934 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2937 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
2938 "below lower bound of %%ld", n+1, name);
2940 msg = xasprintf ("Index '%%ld' of dimension %d "
2941 "below lower bound of %%ld", n+1);
2943 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2945 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2946 fold_convert (long_integer_type_node, index),
2947 fold_convert (long_integer_type_node, tmp_lo));
2955 /* Return the offset for an index. Performs bound checking for elemental
2956 dimensions. Single element references are processed separately.
2957 DIM is the array dimension, I is the loop dimension. */
2960 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2961 gfc_array_ref * ar, tree stride)
2963 gfc_array_info *info;
2968 info = &ss->info->data.array;
2970 /* Get the index into the array for this dimension. */
2973 gcc_assert (ar->type != AR_ELEMENT);
2974 switch (ar->dimen_type[dim])
2976 case DIMEN_THIS_IMAGE:
2980 /* Elemental dimension. */
2981 gcc_assert (info->subscript[dim]
2982 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2983 /* We've already translated this value outside the loop. */
2984 index = info->subscript[dim]->info->data.scalar.value;
2986 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2987 ar->as->type != AS_ASSUMED_SIZE
2988 || dim < ar->dimen - 1);
2992 gcc_assert (info && se->loop);
2993 gcc_assert (info->subscript[dim]
2994 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2995 desc = info->subscript[dim]->info->data.array.descriptor;
2997 /* Get a zero-based index into the vector. */
2998 index = fold_build2_loc (input_location, MINUS_EXPR,
2999 gfc_array_index_type,
3000 se->loop->loopvar[i], se->loop->from[i]);
3002 /* Multiply the index by the stride. */
3003 index = fold_build2_loc (input_location, MULT_EXPR,
3004 gfc_array_index_type,
3005 index, gfc_conv_array_stride (desc, 0));
3007 /* Read the vector to get an index into info->descriptor. */
3008 data = build_fold_indirect_ref_loc (input_location,
3009 gfc_conv_array_data (desc));
3010 index = gfc_build_array_ref (data, index, NULL);
3011 index = gfc_evaluate_now (index, &se->pre);
3012 index = fold_convert (gfc_array_index_type, index);
3014 /* Do any bounds checking on the final info->descriptor index. */
3015 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3016 ar->as->type != AS_ASSUMED_SIZE
3017 || dim < ar->dimen - 1);
3021 /* Scalarized dimension. */
3022 gcc_assert (info && se->loop);
3024 /* Multiply the loop variable by the stride and delta. */
3025 index = se->loop->loopvar[i];
3026 if (!integer_onep (info->stride[dim]))
3027 index = fold_build2_loc (input_location, MULT_EXPR,
3028 gfc_array_index_type, index,
3030 if (!integer_zerop (info->delta[dim]))
3031 index = fold_build2_loc (input_location, PLUS_EXPR,
3032 gfc_array_index_type, index,
3042 /* Temporary array or derived type component. */
3043 gcc_assert (se->loop);
3044 index = se->loop->loopvar[se->loop->order[i]];
3046 /* Pointer functions can have stride[0] different from unity.
3047 Use the stride returned by the function call and stored in
3048 the descriptor for the temporary. */
3049 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3050 && se->ss->info->expr
3051 && se->ss->info->expr->symtree
3052 && se->ss->info->expr->symtree->n.sym->result
3053 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3054 stride = gfc_conv_descriptor_stride_get (info->descriptor,
3057 if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3058 index = fold_build2_loc (input_location, PLUS_EXPR,
3059 gfc_array_index_type, index, info->delta[dim]);
3062 /* Multiply by the stride. */
3063 if (!integer_onep (stride))
3064 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3071 /* Build a scalarized array reference using the vptr 'size'. */
3074 build_class_array_ref (gfc_se *se, tree base, tree index)
3079 tree decl = NULL_TREE;
3081 gfc_expr *expr = se->ss->info->expr;
3083 gfc_ref *class_ref = NULL;
3086 if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
3087 && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
3088 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
3093 || (expr->ts.type != BT_CLASS
3094 && !gfc_is_alloc_class_array_function (expr)
3095 && !gfc_is_class_array_ref (expr, NULL)))
3098 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
3099 ts = &expr->symtree->n.sym->ts;
3103 for (ref = expr->ref; ref; ref = ref->next)
3105 if (ref->type == REF_COMPONENT
3106 && ref->u.c.component->ts.type == BT_CLASS
3107 && ref->next && ref->next->type == REF_COMPONENT
3108 && strcmp (ref->next->u.c.component->name, "_data") == 0
3110 && ref->next->next->type == REF_ARRAY
3111 && ref->next->next->u.ar.type != AR_ELEMENT)
3113 ts = &ref->u.c.component->ts;
3123 if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
3124 && expr->symtree->n.sym == expr->symtree->n.sym->result)
3126 gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
3127 decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
3129 else if (expr && gfc_is_alloc_class_array_function (expr))
3133 for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
3136 type = TREE_TYPE (tmp);
3139 if (GFC_CLASS_TYPE_P (type))
3141 if (type != TYPE_CANONICAL (type))
3142 type = TYPE_CANONICAL (type);
3150 if (decl == NULL_TREE)
3153 else if (class_ref == NULL)
3155 if (decl == NULL_TREE)
3156 decl = expr->symtree->n.sym->backend_decl;
3157 /* For class arrays the tree containing the class is stored in
3158 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3159 For all others it's sym's backend_decl directly. */
3160 if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3161 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3165 /* Remove everything after the last class reference, convert the
3166 expression and then recover its tailend once more. */
3168 ref = class_ref->next;
3169 class_ref->next = NULL;
3170 gfc_init_se (&tmpse, NULL);
3171 gfc_conv_expr (&tmpse, expr);
3172 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3174 class_ref->next = ref;
3177 if (POINTER_TYPE_P (TREE_TYPE (decl)))
3178 decl = build_fold_indirect_ref_loc (input_location, decl);
3180 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3183 size = gfc_class_vtab_size_get (decl);
3185 /* For unlimited polymorphic entities then _len component needs to be
3186 multiplied with the size. If no _len component is present, then
3187 gfc_class_len_or_zero_get () return a zero_node. */
3188 tmp = gfc_class_len_or_zero_get (decl);
3189 if (!integer_zerop (tmp))
3190 size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
3191 fold_convert (TREE_TYPE (index), size),
3192 fold_build2 (MAX_EXPR, TREE_TYPE (index),
3193 fold_convert (TREE_TYPE (index), tmp),
3194 fold_convert (TREE_TYPE (index),
3195 integer_one_node)));
3197 size = fold_convert (TREE_TYPE (index), size);
3199 /* Build the address of the element. */
3200 type = TREE_TYPE (TREE_TYPE (base));
3201 offset = fold_build2_loc (input_location, MULT_EXPR,
3202 gfc_array_index_type,
3204 tmp = gfc_build_addr_expr (pvoid_type_node, base);
3205 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
3206 tmp = fold_convert (build_pointer_type (type), tmp);
3208 /* Return the element in the se expression. */
3209 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
3214 /* Build a scalarized reference to an array. */
3217 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3219 gfc_array_info *info;
3220 tree decl = NULL_TREE;
3228 expr = ss->info->expr;
3229 info = &ss->info->data.array;
3231 n = se->loop->order[0];
3235 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3236 /* Add the offset for this dimension to the stored offset for all other
3238 if (info->offset && !integer_zerop (info->offset))
3239 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3240 index, info->offset);
3242 if (expr && (is_subref_array (expr)
3243 || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
3244 || expr->expr_type == EXPR_FUNCTION))))
3245 decl = expr->symtree->n.sym->backend_decl;
3247 tmp = build_fold_indirect_ref_loc (input_location, info->data);
3249 /* Use the vptr 'size' field to access a class the element of a class
3251 if (build_class_array_ref (se, tmp, index))
3254 se->expr = gfc_build_array_ref (tmp, index, decl);
3258 /* Translate access of temporary array. */
3261 gfc_conv_tmp_array_ref (gfc_se * se)
3263 se->string_length = se->ss->info->string_length;
3264 gfc_conv_scalarized_array_ref (se, NULL);
3265 gfc_advance_se_ss_chain (se);
3268 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3271 add_to_offset (tree *cst_offset, tree *offset, tree t)
3273 if (TREE_CODE (t) == INTEGER_CST)
3274 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3277 if (!integer_zerop (*offset))
3278 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3279 gfc_array_index_type, *offset, t);
3287 build_array_ref (tree desc, tree offset, tree decl, tree vptr)
3292 bool classarray = false;
3294 /* For class arrays the class declaration is stored in the saved
3296 if (INDIRECT_REF_P (desc)
3297 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
3298 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
3299 cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3300 TREE_OPERAND (desc, 0)));
3304 /* Class container types do not always have the GFC_CLASS_TYPE_P
3305 but the canonical type does. */
3306 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
3307 && TREE_CODE (cdecl) == COMPONENT_REF)
3309 type = TREE_TYPE (TREE_OPERAND (cdecl, 0));
3310 if (TYPE_CANONICAL (type)
3311 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
3313 type = TREE_TYPE (desc);
3320 /* Class array references need special treatment because the assigned
3321 type size needs to be used to point to the element. */
3324 type = gfc_get_element_type (type);
3325 tmp = TREE_OPERAND (cdecl, 0);
3326 tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
3327 tmp = fold_convert (build_pointer_type (type), tmp);
3328 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3332 tmp = gfc_conv_array_data (desc);
3333 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3334 tmp = gfc_build_array_ref (tmp, offset, decl, vptr);
3339 /* Build an array reference. se->expr already holds the array descriptor.
3340 This should be either a variable, indirect variable reference or component
3341 reference. For arrays which do not have a descriptor, se->expr will be
3343 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3346 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3350 tree offset, cst_offset;
3355 gfc_symbol * sym = expr->symtree->n.sym;
3356 char *var_name = NULL;
3360 gcc_assert (ar->codimen);
3362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3363 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3366 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3367 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3368 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3370 /* Use the actual tree type and not the wrapped coarray. */
3371 if (!se->want_pointer)
3372 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3379 /* Handle scalarized references separately. */
3380 if (ar->type != AR_ELEMENT)
3382 gfc_conv_scalarized_array_ref (se, ar);
3383 gfc_advance_se_ss_chain (se);
3387 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3392 len = strlen (sym->name) + 1;
3393 for (ref = expr->ref; ref; ref = ref->next)
3395 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3397 if (ref->type == REF_COMPONENT)
3398 len += 2 + strlen (ref->u.c.component->name);
3401 var_name = XALLOCAVEC (char, len);
3402 strcpy (var_name, sym->name);
3404 for (ref = expr->ref; ref; ref = ref->next)
3406 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3408 if (ref->type == REF_COMPONENT)
3410 strcat (var_name, "%%");
3411 strcat (var_name, ref->u.c.component->name);
3416 cst_offset = offset = gfc_index_zero_node;
3417 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3419 /* Calculate the offsets from all the dimensions. Make sure to associate
3420 the final offset so that we form a chain of loop invariant summands. */
3421 for (n = ar->dimen - 1; n >= 0; n--)
3423 /* Calculate the index for this dimension. */
3424 gfc_init_se (&indexse, se);
3425 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3426 gfc_add_block_to_block (&se->pre, &indexse.pre);
3428 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3430 /* Check array bounds. */
3434 /* Evaluate the indexse.expr only once. */
3435 indexse.expr = save_expr (indexse.expr);
3438 tmp = gfc_conv_array_lbound (se->expr, n);
3439 if (sym->attr.temporary)
3441 gfc_init_se (&tmpse, se);
3442 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3443 gfc_array_index_type);
3444 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3448 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3450 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3451 "below lower bound of %%ld", n+1, var_name);
3452 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3453 fold_convert (long_integer_type_node,
3455 fold_convert (long_integer_type_node, tmp));
3458 /* Upper bound, but not for the last dimension of assumed-size
3460 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3462 tmp = gfc_conv_array_ubound (se->expr, n);
3463 if (sym->attr.temporary)
3465 gfc_init_se (&tmpse, se);
3466 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3467 gfc_array_index_type);
3468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3472 cond = fold_build2_loc (input_location, GT_EXPR,
3473 boolean_type_node, indexse.expr, tmp);
3474 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3475 "above upper bound of %%ld", n+1, var_name);
3476 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3477 fold_convert (long_integer_type_node,
3479 fold_convert (long_integer_type_node, tmp));
3484 /* Multiply the index by the stride. */
3485 stride = gfc_conv_array_stride (se->expr, n);
3486 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3487 indexse.expr, stride);
3489 /* And add it to the total. */
3490 add_to_offset (&cst_offset, &offset, tmp);
3493 if (!integer_zerop (cst_offset))
3494 offset = fold_build2_loc (input_location, PLUS_EXPR,
3495 gfc_array_index_type, offset, cst_offset);
3497 se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ?
3498 NULL_TREE : sym->backend_decl, se->class_vptr);
3502 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3503 LOOP_DIM dimension (if any) to array's offset. */
3506 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3507 gfc_array_ref *ar, int array_dim, int loop_dim)
3510 gfc_array_info *info;
3513 info = &ss->info->data.array;
3515 gfc_init_se (&se, NULL);
3517 se.expr = info->descriptor;
3518 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3519 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3520 gfc_add_block_to_block (pblock, &se.pre);
3522 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3523 gfc_array_index_type,
3524 info->offset, index);
3525 info->offset = gfc_evaluate_now (info->offset, pblock);
3529 /* Generate the code to be executed immediately before entering a
3530 scalarization loop. */
3533 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3534 stmtblock_t * pblock)
3537 gfc_ss_info *ss_info;
3538 gfc_array_info *info;
3539 gfc_ss_type ss_type;
3541 gfc_loopinfo *ploop;
3545 /* This code will be executed before entering the scalarization loop
3546 for this dimension. */
3547 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3551 if ((ss_info->useflags & flag) == 0)
3554 ss_type = ss_info->type;
3555 if (ss_type != GFC_SS_SECTION
3556 && ss_type != GFC_SS_FUNCTION
3557 && ss_type != GFC_SS_CONSTRUCTOR
3558 && ss_type != GFC_SS_COMPONENT)
3561 info = &ss_info->data.array;
3563 gcc_assert (dim < ss->dimen);
3564 gcc_assert (ss->dimen == loop->dimen);
3567 ar = &info->ref->u.ar;
3571 if (dim == loop->dimen - 1 && loop->parent != NULL)
3573 /* If we are in the outermost dimension of this loop, the previous
3574 dimension shall be in the parent loop. */
3575 gcc_assert (ss->parent != NULL);
3578 ploop = loop->parent;
3580 /* ss and ss->parent are about the same array. */
3581 gcc_assert (ss_info == pss->info);
3589 if (dim == loop->dimen - 1)
3594 /* For the time being, there is no loop reordering. */
3595 gcc_assert (i == ploop->order[i]);
3596 i = ploop->order[i];
3598 if (dim == loop->dimen - 1 && loop->parent == NULL)
3600 stride = gfc_conv_array_stride (info->descriptor,
3601 innermost_ss (ss)->dim[i]);
3603 /* Calculate the stride of the innermost loop. Hopefully this will
3604 allow the backend optimizers to do their stuff more effectively.
3606 info->stride0 = gfc_evaluate_now (stride, pblock);
3608 /* For the outermost loop calculate the offset due to any
3609 elemental dimensions. It will have been initialized with the
3610 base offset of the array. */
3613 for (i = 0; i < ar->dimen; i++)
3615 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3618 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3623 /* Add the offset for the previous loop dimension. */
3624 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3626 /* Remember this offset for the second loop. */
3627 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3628 info->saved_offset = info->offset;
3633 /* Start a scalarized expression. Creates a scope and declares loop
3637 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3643 gcc_assert (!loop->array_parameter);
3645 for (dim = loop->dimen - 1; dim >= 0; dim--)
3647 n = loop->order[dim];
3649 gfc_start_block (&loop->code[n]);
3651 /* Create the loop variable. */
3652 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3654 if (dim < loop->temp_dim)
3658 /* Calculate values that will be constant within this loop. */
3659 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3661 gfc_start_block (pbody);
3665 /* Generates the actual loop code for a scalarization loop. */
3668 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3669 stmtblock_t * pbody)
3680 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS
3681 | OMPWS_SCALARIZER_BODY))
3682 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3683 && n == loop->dimen - 1)
3685 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3686 init = make_tree_vec (1);
3687 cond = make_tree_vec (1);
3688 incr = make_tree_vec (1);
3690 /* Cycle statement is implemented with a goto. Exit statement must not
3691 be present for this loop. */
3692 exit_label = gfc_build_label_decl (NULL_TREE);
3693 TREE_USED (exit_label) = 1;
3695 /* Label for cycle statements (if needed). */
3696 tmp = build1_v (LABEL_EXPR, exit_label);
3697 gfc_add_expr_to_block (pbody, tmp);
3699 stmt = make_node (OMP_FOR);
3701 TREE_TYPE (stmt) = void_type_node;
3702 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3704 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3705 OMP_CLAUSE_SCHEDULE);
3706 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3707 = OMP_CLAUSE_SCHEDULE_STATIC;
3708 if (ompws_flags & OMPWS_NOWAIT)
3709 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3710 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3712 /* Initialize the loopvar. */
3713 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3715 OMP_FOR_INIT (stmt) = init;
3716 /* The exit condition. */
3717 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3719 loop->loopvar[n], loop->to[n]);
3720 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3721 OMP_FOR_COND (stmt) = cond;
3722 /* Increment the loopvar. */
3723 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3724 loop->loopvar[n], gfc_index_one_node);
3725 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3726 void_type_node, loop->loopvar[n], tmp);
3727 OMP_FOR_INCR (stmt) = incr;
3729 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3730 gfc_add_expr_to_block (&loop->code[n], stmt);
3734 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3735 && (loop->temp_ss == NULL);
3737 loopbody = gfc_finish_block (pbody);
3740 std::swap (loop->from[n], loop->to[n]);
3742 /* Initialize the loopvar. */
3743 if (loop->loopvar[n] != loop->from[n])
3744 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3746 exit_label = gfc_build_label_decl (NULL_TREE);
3748 /* Generate the loop body. */
3749 gfc_init_block (&block);
3751 /* The exit condition. */
3752 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3753 boolean_type_node, loop->loopvar[n], loop->to[n]);
3754 tmp = build1_v (GOTO_EXPR, exit_label);
3755 TREE_USED (exit_label) = 1;
3756 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3757 gfc_add_expr_to_block (&block, tmp);
3759 /* The main body. */
3760 gfc_add_expr_to_block (&block, loopbody);
3762 /* Increment the loopvar. */
3763 tmp = fold_build2_loc (input_location,
3764 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3765 gfc_array_index_type, loop->loopvar[n],
3766 gfc_index_one_node);
3768 gfc_add_modify (&block, loop->loopvar[n], tmp);
3770 /* Build the loop. */
3771 tmp = gfc_finish_block (&block);
3772 tmp = build1_v (LOOP_EXPR, tmp);
3773 gfc_add_expr_to_block (&loop->code[n], tmp);
3775 /* Add the exit label. */
3776 tmp = build1_v (LABEL_EXPR, exit_label);
3777 gfc_add_expr_to_block (&loop->code[n], tmp);
3783 /* Finishes and generates the loops for a scalarized expression. */
3786 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3791 stmtblock_t *pblock;
3795 /* Generate the loops. */
3796 for (dim = 0; dim < loop->dimen; dim++)
3798 n = loop->order[dim];
3799 gfc_trans_scalarized_loop_end (loop, n, pblock);
3800 loop->loopvar[n] = NULL_TREE;
3801 pblock = &loop->code[n];
3804 tmp = gfc_finish_block (pblock);
3805 gfc_add_expr_to_block (&loop->pre, tmp);
3807 /* Clear all the used flags. */
3808 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3809 if (ss->parent == NULL)
3810 ss->info->useflags = 0;
3814 /* Finish the main body of a scalarized expression, and start the secondary
3818 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3822 stmtblock_t *pblock;
3826 /* We finish as many loops as are used by the temporary. */
3827 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3829 n = loop->order[dim];
3830 gfc_trans_scalarized_loop_end (loop, n, pblock);
3831 loop->loopvar[n] = NULL_TREE;
3832 pblock = &loop->code[n];
3835 /* We don't want to finish the outermost loop entirely. */
3836 n = loop->order[loop->temp_dim - 1];
3837 gfc_trans_scalarized_loop_end (loop, n, pblock);
3839 /* Restore the initial offsets. */
3840 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3842 gfc_ss_type ss_type;
3843 gfc_ss_info *ss_info;
3847 if ((ss_info->useflags & 2) == 0)
3850 ss_type = ss_info->type;
3851 if (ss_type != GFC_SS_SECTION
3852 && ss_type != GFC_SS_FUNCTION
3853 && ss_type != GFC_SS_CONSTRUCTOR
3854 && ss_type != GFC_SS_COMPONENT)
3857 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3860 /* Restart all the inner loops we just finished. */
3861 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3863 n = loop->order[dim];
3865 gfc_start_block (&loop->code[n]);
3867 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3869 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3872 /* Start a block for the secondary copying code. */
3873 gfc_start_block (body);
3877 /* Precalculate (either lower or upper) bound of an array section.
3878 BLOCK: Block in which the (pre)calculation code will go.
3879 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3880 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3881 DESC: Array descriptor from which the bound will be picked if unspecified
3882 (either lower or upper bound according to LBOUND). */
3885 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3886 tree desc, int dim, bool lbound, bool deferred)
3889 gfc_expr * input_val = values[dim];
3890 tree *output = &bounds[dim];
3895 /* Specified section bound. */
3896 gfc_init_se (&se, NULL);
3897 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3898 gfc_add_block_to_block (block, &se.pre);
3901 else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
3903 /* The gfc_conv_array_lbound () routine returns a constant zero for
3904 deferred length arrays, which in the scalarizer wreaks havoc, when
3905 copying to a (newly allocated) one-based array.
3906 Keep returning the actual result in sync for both bounds. */
3907 *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
3909 gfc_conv_descriptor_ubound_get (desc,
3914 /* No specific bound specified so use the bound of the array. */
3915 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3916 gfc_conv_array_ubound (desc, dim);
3918 *output = gfc_evaluate_now (*output, block);
3922 /* Calculate the lower bound of an array section. */
3925 gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
3927 gfc_expr *stride = NULL;
3930 gfc_array_info *info;
3933 gcc_assert (ss->info->type == GFC_SS_SECTION);
3935 info = &ss->info->data.array;
3936 ar = &info->ref->u.ar;
3938 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3940 /* We use a zero-based index to access the vector. */
3941 info->start[dim] = gfc_index_zero_node;
3942 info->end[dim] = NULL;
3943 info->stride[dim] = gfc_index_one_node;
3947 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3948 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3949 desc = info->descriptor;
3950 stride = ar->stride[dim];
3953 /* Calculate the start of the range. For vector subscripts this will
3954 be the range of the vector. */
3955 evaluate_bound (block, info->start, ar->start, desc, dim, true,
3956 ar->as->type == AS_DEFERRED);
3958 /* Similarly calculate the end. Although this is not used in the
3959 scalarizer, it is needed when checking bounds and where the end
3960 is an expression with side-effects. */
3961 evaluate_bound (block, info->end, ar->end, desc, dim, false,
3962 ar->as->type == AS_DEFERRED);
3965 /* Calculate the stride. */
3967 info->stride[dim] = gfc_index_one_node;
3970 gfc_init_se (&se, NULL);
3971 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3972 gfc_add_block_to_block (block, &se.pre);
3973 info->stride[dim] = gfc_evaluate_now (se.expr, block);
3978 /* Calculates the range start and stride for a SS chain. Also gets the
3979 descriptor and data pointer. The range of vector subscripts is the size
3980 of the vector. Array bounds are also checked. */
3983 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3990 gfc_loopinfo * const outer_loop = outermost_loop (loop);
3993 /* Determine the rank of the loop. */
3994 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3996 switch (ss->info->type)
3998 case GFC_SS_SECTION:
3999 case GFC_SS_CONSTRUCTOR:
4000 case GFC_SS_FUNCTION:
4001 case GFC_SS_COMPONENT:
4002 loop->dimen = ss->dimen;
4005 /* As usual, lbound and ubound are exceptions!. */
4006 case GFC_SS_INTRINSIC:
4007 switch (ss->info->expr->value.function.isym->id)
4009 case GFC_ISYM_LBOUND:
4010 case GFC_ISYM_UBOUND:
4011 case GFC_ISYM_LCOBOUND:
4012 case GFC_ISYM_UCOBOUND:
4013 case GFC_ISYM_THIS_IMAGE:
4014 loop->dimen = ss->dimen;
4026 /* We should have determined the rank of the expression by now. If
4027 not, that's bad news. */
4031 /* Loop over all the SS in the chain. */
4032 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4034 gfc_ss_info *ss_info;
4035 gfc_array_info *info;
4039 expr = ss_info->expr;
4040 info = &ss_info->data.array;
4042 if (expr && expr->shape && !info->shape)
4043 info->shape = expr->shape;
4045 switch (ss_info->type)
4047 case GFC_SS_SECTION:
4048 /* Get the descriptor for the array. If it is a cross loops array,
4049 we got the descriptor already in the outermost loop. */
4050 if (ss->parent == NULL)
4051 gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4052 !loop->array_parameter);
4054 for (n = 0; n < ss->dimen; n++)
4055 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4058 case GFC_SS_INTRINSIC:
4059 switch (expr->value.function.isym->id)
4061 /* Fall through to supply start and stride. */
4062 case GFC_ISYM_LBOUND:
4063 case GFC_ISYM_UBOUND:
4067 /* This is the variant without DIM=... */
4068 gcc_assert (expr->value.function.actual->next->expr == NULL);
4070 arg = expr->value.function.actual->expr;
4071 if (arg->rank == -1)
4076 /* The rank (hence the return value's shape) is unknown,
4077 we have to retrieve it. */
4078 gfc_init_se (&se, NULL);
4079 se.descriptor_only = 1;
4080 gfc_conv_expr (&se, arg);
4081 /* This is a bare variable, so there is no preliminary
4083 gcc_assert (se.pre.head == NULL_TREE
4084 && se.post.head == NULL_TREE);
4085 rank = gfc_conv_descriptor_rank (se.expr);
4086 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4087 gfc_array_index_type,
4088 fold_convert (gfc_array_index_type,
4090 gfc_index_one_node);
4091 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
4092 info->start[0] = gfc_index_zero_node;
4093 info->stride[0] = gfc_index_one_node;
4096 /* Otherwise fall through GFC_SS_FUNCTION. */
4099 case GFC_ISYM_LCOBOUND:
4100 case GFC_ISYM_UCOBOUND:
4101 case GFC_ISYM_THIS_IMAGE:
4109 case GFC_SS_CONSTRUCTOR:
4110 case GFC_SS_FUNCTION:
4111 for (n = 0; n < ss->dimen; n++)
4113 int dim = ss->dim[n];
4115 info->start[dim] = gfc_index_zero_node;
4116 info->end[dim] = gfc_index_zero_node;
4117 info->stride[dim] = gfc_index_one_node;
4126 /* The rest is just runtime bound checking. */
4127 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4130 tree lbound, ubound;
4132 tree size[GFC_MAX_DIMENSIONS];
4133 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
4134 gfc_array_info *info;
4138 gfc_start_block (&block);
4140 for (n = 0; n < loop->dimen; n++)
4141 size[n] = NULL_TREE;
4143 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4146 gfc_ss_info *ss_info;
4149 const char *expr_name;
4152 if (ss_info->type != GFC_SS_SECTION)
4155 /* Catch allocatable lhs in f2003. */
4156 if (flag_realloc_lhs && ss->is_alloc_lhs)
4159 expr = ss_info->expr;
4160 expr_loc = &expr->where;
4161 expr_name = expr->symtree->name;
4163 gfc_start_block (&inner);
4165 /* TODO: range checking for mapped dimensions. */
4166 info = &ss_info->data.array;
4168 /* This code only checks ranges. Elemental and vector
4169 dimensions are checked later. */
4170 for (n = 0; n < loop->dimen; n++)
4175 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4178 if (dim == info->ref->u.ar.dimen - 1
4179 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4180 check_upper = false;
4184 /* Zero stride is not allowed. */
4185 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4186 info->stride[dim], gfc_index_zero_node);
4187 msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4188 "of array '%s'", dim + 1, expr_name);
4189 gfc_trans_runtime_check (true, false, tmp, &inner,
4193 desc = info->descriptor;
4195 /* This is the run-time equivalent of resolve.c's
4196 check_dimension(). The logical is more readable there
4197 than it is here, with all the trees. */
4198 lbound = gfc_conv_array_lbound (desc, dim);
4199 end = info->end[dim];
4201 ubound = gfc_conv_array_ubound (desc, dim);
4205 /* non_zerosized is true when the selected range is not
4207 stride_pos = fold_build2_loc (input_location, GT_EXPR,
4208 boolean_type_node, info->stride[dim],
4209 gfc_index_zero_node);
4210 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4211 info->start[dim], end);
4212 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4213 boolean_type_node, stride_pos, tmp);
4215 stride_neg = fold_build2_loc (input_location, LT_EXPR,
4217 info->stride[dim], gfc_index_zero_node);
4218 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4219 info->start[dim], end);
4220 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4223 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4225 stride_pos, stride_neg);
4227 /* Check the start of the range against the lower and upper
4228 bounds of the array, if the range is not empty.
4229 If upper bound is present, include both bounds in the
4233 tmp = fold_build2_loc (input_location, LT_EXPR,
4235 info->start[dim], lbound);
4236 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4238 non_zerosized, tmp);
4239 tmp2 = fold_build2_loc (input_location, GT_EXPR,
4241 info->start[dim], ubound);
4242 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4244 non_zerosized, tmp2);
4245 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4246 "outside of expected range (%%ld:%%ld)",
4247 dim + 1, expr_name);
4248 gfc_trans_runtime_check (true, false, tmp, &inner,
4250 fold_convert (long_integer_type_node, info->start[dim]),
4251 fold_convert (long_integer_type_node, lbound),
4252 fold_convert (long_integer_type_node, ubound));
4253 gfc_trans_runtime_check (true, false, tmp2, &inner,
4255 fold_convert (long_integer_type_node, info->start[dim]),
4256 fold_convert (long_integer_type_node, lbound),
4257 fold_convert (long_integer_type_node, ubound));
4262 tmp = fold_build2_loc (input_location, LT_EXPR,
4264 info->start[dim], lbound);
4265 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4266 boolean_type_node, non_zerosized, tmp);
4267 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4268 "below lower bound of %%ld",
4269 dim + 1, expr_name);
4270 gfc_trans_runtime_check (true, false, tmp, &inner,
4272 fold_convert (long_integer_type_node, info->start[dim]),
4273 fold_convert (long_integer_type_node, lbound));
4277 /* Compute the last element of the range, which is not
4278 necessarily "end" (think 0:5:3, which doesn't contain 5)
4279 and check it against both lower and upper bounds. */
4281 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4282 gfc_array_index_type, end,
4284 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4285 gfc_array_index_type, tmp,
4287 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4288 gfc_array_index_type, end, tmp);
4289 tmp2 = fold_build2_loc (input_location, LT_EXPR,
4290 boolean_type_node, tmp, lbound);
4291 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4292 boolean_type_node, non_zerosized, tmp2);
4295 tmp3 = fold_build2_loc (input_location, GT_EXPR,
4296 boolean_type_node, tmp, ubound);
4297 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4298 boolean_type_node, non_zerosized, tmp3);
4299 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4300 "outside of expected range (%%ld:%%ld)",
4301 dim + 1, expr_name);
4302 gfc_trans_runtime_check (true, false, tmp2, &inner,
4304 fold_convert (long_integer_type_node, tmp),
4305 fold_convert (long_integer_type_node, ubound),
4306 fold_convert (long_integer_type_node, lbound));
4307 gfc_trans_runtime_check (true, false, tmp3, &inner,
4309 fold_convert (long_integer_type_node, tmp),
4310 fold_convert (long_integer_type_node, ubound),
4311 fold_convert (long_integer_type_node, lbound));
4316 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4317 "below lower bound of %%ld",
4318 dim + 1, expr_name);
4319 gfc_trans_runtime_check (true, false, tmp2, &inner,
4321 fold_convert (long_integer_type_node, tmp),
4322 fold_convert (long_integer_type_node, lbound));
4326 /* Check the section sizes match. */
4327 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4328 gfc_array_index_type, end,
4330 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4331 gfc_array_index_type, tmp,
4333 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4334 gfc_array_index_type,
4335 gfc_index_one_node, tmp);
4336 tmp = fold_build2_loc (input_location, MAX_EXPR,
4337 gfc_array_index_type, tmp,
4338 build_int_cst (gfc_array_index_type, 0));
4339 /* We remember the size of the first section, and check all the
4340 others against this. */
4343 tmp3 = fold_build2_loc (input_location, NE_EXPR,
4344 boolean_type_node, tmp, size[n]);
4345 msg = xasprintf ("Array bound mismatch for dimension %d "
4346 "of array '%s' (%%ld/%%ld)",
4347 dim + 1, expr_name);
4349 gfc_trans_runtime_check (true, false, tmp3, &inner,
4351 fold_convert (long_integer_type_node, tmp),
4352 fold_convert (long_integer_type_node, size[n]));
4357 size[n] = gfc_evaluate_now (tmp, &inner);
4360 tmp = gfc_finish_block (&inner);
4362 /* For optional arguments, only check bounds if the argument is
4364 if (expr->symtree->n.sym->attr.optional
4365 || expr->symtree->n.sym->attr.not_always_present)
4366 tmp = build3_v (COND_EXPR,
4367 gfc_conv_expr_present (expr->symtree->n.sym),
4368 tmp, build_empty_stmt (input_location));
4370 gfc_add_expr_to_block (&block, tmp);
4374 tmp = gfc_finish_block (&block);
4375 gfc_add_expr_to_block (&outer_loop->pre, tmp);
4378 for (loop = loop->nested; loop; loop = loop->next)
4379 gfc_conv_ss_startstride (loop);
4382 /* Return true if both symbols could refer to the same data object. Does
4383 not take account of aliasing due to equivalence statements. */
4386 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4387 bool lsym_target, bool rsym_pointer, bool rsym_target)
4389 /* Aliasing isn't possible if the symbols have different base types. */
4390 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4393 /* Pointers can point to other pointers and target objects. */
4395 if ((lsym_pointer && (rsym_pointer || rsym_target))
4396 || (rsym_pointer && (lsym_pointer || lsym_target)))
4399 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4400 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4402 if (lsym_target && rsym_target
4403 && ((lsym->attr.dummy && !lsym->attr.contiguous
4404 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4405 || (rsym->attr.dummy && !rsym->attr.contiguous
4406 && (!rsym->attr.dimension
4407 || rsym->as->type == AS_ASSUMED_SHAPE))))
4414 /* Return true if the two SS could be aliased, i.e. both point to the same data
4416 /* TODO: resolve aliases based on frontend expressions. */
4419 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4423 gfc_expr *lexpr, *rexpr;
4426 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4428 lexpr = lss->info->expr;
4429 rexpr = rss->info->expr;
4431 lsym = lexpr->symtree->n.sym;
4432 rsym = rexpr->symtree->n.sym;
4434 lsym_pointer = lsym->attr.pointer;
4435 lsym_target = lsym->attr.target;
4436 rsym_pointer = rsym->attr.pointer;
4437 rsym_target = rsym->attr.target;
4439 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4440 rsym_pointer, rsym_target))
4443 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4444 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4447 /* For derived types we must check all the component types. We can ignore
4448 array references as these will have the same base type as the previous
4450 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4452 if (lref->type != REF_COMPONENT)
4455 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4456 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4458 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4459 rsym_pointer, rsym_target))
4462 if ((lsym_pointer && (rsym_pointer || rsym_target))
4463 || (rsym_pointer && (lsym_pointer || lsym_target)))
4465 if (gfc_compare_types (&lref->u.c.component->ts,
4470 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4473 if (rref->type != REF_COMPONENT)
4476 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4477 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4479 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4480 lsym_pointer, lsym_target,
4481 rsym_pointer, rsym_target))
4484 if ((lsym_pointer && (rsym_pointer || rsym_target))
4485 || (rsym_pointer && (lsym_pointer || lsym_target)))
4487 if (gfc_compare_types (&lref->u.c.component->ts,
4488 &rref->u.c.sym->ts))
4490 if (gfc_compare_types (&lref->u.c.sym->ts,
4491 &rref->u.c.component->ts))
4493 if (gfc_compare_types (&lref->u.c.component->ts,
4494 &rref->u.c.component->ts))
4500 lsym_pointer = lsym->attr.pointer;
4501 lsym_target = lsym->attr.target;
4502 lsym_pointer = lsym->attr.pointer;
4503 lsym_target = lsym->attr.target;
4505 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4507 if (rref->type != REF_COMPONENT)
4510 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4511 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4513 if (symbols_could_alias (rref->u.c.sym, lsym,
4514 lsym_pointer, lsym_target,
4515 rsym_pointer, rsym_target))
4518 if ((lsym_pointer && (rsym_pointer || rsym_target))
4519 || (rsym_pointer && (lsym_pointer || lsym_target)))
4521 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4530 /* Resolve array data dependencies. Creates a temporary if required. */
4531 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4535 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4541 gfc_ss_info *ss_info;
4542 gfc_expr *dest_expr;
4547 loop->temp_ss = NULL;
4548 dest_expr = dest->info->expr;
4550 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4553 ss_expr = ss_info->expr;
4555 if (ss_info->array_outer_dependency)
4561 if (ss_info->type != GFC_SS_SECTION)
4563 if (flag_realloc_lhs
4564 && dest_expr != ss_expr
4565 && gfc_is_reallocatable_lhs (dest_expr)
4567 nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
4569 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
4570 if (!nDepend && dest_expr->rank > 0
4571 && dest_expr->ts.type == BT_CHARACTER
4572 && ss_expr->expr_type == EXPR_VARIABLE)
4574 nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
4576 if (ss_info->type == GFC_SS_REFERENCE
4577 && gfc_check_dependency (dest_expr, ss_expr, false))
4578 ss_info->data.scalar.needs_temporary = 1;
4583 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4585 if (gfc_could_be_alias (dest, ss)
4586 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4594 lref = dest_expr->ref;
4595 rref = ss_expr->ref;
4597 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4602 for (i = 0; i < dest->dimen; i++)
4603 for (j = 0; j < ss->dimen; j++)
4605 && dest->dim[i] == ss->dim[j])
4607 /* If we don't access array elements in the same order,
4608 there is a dependency. */
4613 /* TODO : loop shifting. */
4616 /* Mark the dimensions for LOOP SHIFTING */
4617 for (n = 0; n < loop->dimen; n++)
4619 int dim = dest->data.info.dim[n];
4621 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4623 else if (! gfc_is_same_range (&lref->u.ar,
4624 &rref->u.ar, dim, 0))
4628 /* Put all the dimensions with dependencies in the
4631 for (n = 0; n < loop->dimen; n++)
4633 gcc_assert (loop->order[n] == n);
4635 loop->order[dim++] = n;
4637 for (n = 0; n < loop->dimen; n++)
4640 loop->order[dim++] = n;
4643 gcc_assert (dim == loop->dimen);
4654 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4655 if (GFC_ARRAY_TYPE_P (base_type)
4656 || GFC_DESCRIPTOR_TYPE_P (base_type))
4657 base_type = gfc_get_element_type (base_type);
4658 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4660 gfc_add_ss_to_loop (loop, loop->temp_ss);
4663 loop->temp_ss = NULL;
4667 /* Browse through each array's information from the scalarizer and set the loop
4668 bounds according to the "best" one (per dimension), i.e. the one which
4669 provides the most information (constant bounds, shape, etc.). */
4672 set_loop_bounds (gfc_loopinfo *loop)
4674 int n, dim, spec_dim;
4675 gfc_array_info *info;
4676 gfc_array_info *specinfo;
4680 bool dynamic[GFC_MAX_DIMENSIONS];
4683 bool nonoptional_arr;
4685 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4687 loopspec = loop->specloop;
4690 for (n = 0; n < loop->dimen; n++)
4695 /* If there are both optional and nonoptional array arguments, scalarize
4696 over the nonoptional; otherwise, it does not matter as then all
4697 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4699 nonoptional_arr = false;
4701 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4702 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
4703 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
4705 nonoptional_arr = true;
4709 /* We use one SS term, and use that to determine the bounds of the
4710 loop for this dimension. We try to pick the simplest term. */
4711 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4713 gfc_ss_type ss_type;
4715 ss_type = ss->info->type;
4716 if (ss_type == GFC_SS_SCALAR
4717 || ss_type == GFC_SS_TEMP
4718 || ss_type == GFC_SS_REFERENCE
4719 || (ss->info->can_be_null_ref && nonoptional_arr))
4722 info = &ss->info->data.array;
4725 if (loopspec[n] != NULL)
4727 specinfo = &loopspec[n]->info->data.array;
4728 spec_dim = loopspec[n]->dim[n];
4732 /* Silence uninitialized warnings. */
4739 gcc_assert (info->shape[dim]);
4740 /* The frontend has worked out the size for us. */
4743 || !integer_zerop (specinfo->start[spec_dim]))
4744 /* Prefer zero-based descriptors if possible. */
4749 if (ss_type == GFC_SS_CONSTRUCTOR)
4751 gfc_constructor_base base;
4752 /* An unknown size constructor will always be rank one.
4753 Higher rank constructors will either have known shape,
4754 or still be wrapped in a call to reshape. */
4755 gcc_assert (loop->dimen == 1);
4757 /* Always prefer to use the constructor bounds if the size
4758 can be determined at compile time. Prefer not to otherwise,
4759 since the general case involves realloc, and it's better to
4760 avoid that overhead if possible. */
4761 base = ss->info->expr->value.constructor;
4762 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4763 if (!dynamic[n] || !loopspec[n])
4768 /* Avoid using an allocatable lhs in an assignment, since
4769 there might be a reallocation coming. */
4770 if (loopspec[n] && ss->is_alloc_lhs)
4775 /* Criteria for choosing a loop specifier (most important first):
4776 doesn't need realloc
4782 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4784 else if (integer_onep (info->stride[dim])
4785 && !integer_onep (specinfo->stride[spec_dim]))
4787 else if (INTEGER_CST_P (info->stride[dim])
4788 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4790 else if (INTEGER_CST_P (info->start[dim])
4791 && !INTEGER_CST_P (specinfo->start[spec_dim])
4792 && integer_onep (info->stride[dim])
4793 == integer_onep (specinfo->stride[spec_dim])
4794 && INTEGER_CST_P (info->stride[dim])
4795 == INTEGER_CST_P (specinfo->stride[spec_dim]))
4797 /* We don't work out the upper bound.
4798 else if (INTEGER_CST_P (info->finish[n])
4799 && ! INTEGER_CST_P (specinfo->finish[n]))
4800 loopspec[n] = ss; */
4803 /* We should have found the scalarization loop specifier. If not,
4805 gcc_assert (loopspec[n]);
4807 info = &loopspec[n]->info->data.array;
4808 dim = loopspec[n]->dim[n];
4810 /* Set the extents of this range. */
4811 cshape = info->shape;
4812 if (cshape && INTEGER_CST_P (info->start[dim])
4813 && INTEGER_CST_P (info->stride[dim]))
4815 loop->from[n] = info->start[dim];
4816 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
4817 mpz_sub_ui (i, i, 1);
4818 /* To = from + (size - 1) * stride. */
4819 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4820 if (!integer_onep (info->stride[dim]))
4821 tmp = fold_build2_loc (input_location, MULT_EXPR,
4822 gfc_array_index_type, tmp,
4824 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4825 gfc_array_index_type,
4826 loop->from[n], tmp);
4830 loop->from[n] = info->start[dim];
4831 switch (loopspec[n]->info->type)
4833 case GFC_SS_CONSTRUCTOR:
4834 /* The upper bound is calculated when we expand the
4836 gcc_assert (loop->to[n] == NULL_TREE);
4839 case GFC_SS_SECTION:
4840 /* Use the end expression if it exists and is not constant,
4841 so that it is only evaluated once. */
4842 loop->to[n] = info->end[dim];
4845 case GFC_SS_FUNCTION:
4846 /* The loop bound will be set when we generate the call. */
4847 gcc_assert (loop->to[n] == NULL_TREE);
4850 case GFC_SS_INTRINSIC:
4852 gfc_expr *expr = loopspec[n]->info->expr;
4854 /* The {l,u}bound of an assumed rank. */
4855 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
4856 || expr->value.function.isym->id == GFC_ISYM_UBOUND)
4857 && expr->value.function.actual->next->expr == NULL
4858 && expr->value.function.actual->expr->rank == -1);
4860 loop->to[n] = info->end[dim];
4869 /* Transform everything so we have a simple incrementing variable. */
4870 if (integer_onep (info->stride[dim]))
4871 info->delta[dim] = gfc_index_zero_node;
4874 /* Set the delta for this section. */
4875 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
4876 /* Number of iterations is (end - start + step) / step.
4877 with start = 0, this simplifies to
4879 for (i = 0; i<=last; i++){...}; */
4880 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4881 gfc_array_index_type, loop->to[n],
4883 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4884 gfc_array_index_type, tmp, info->stride[dim]);
4885 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4886 tmp, build_int_cst (gfc_array_index_type, -1));
4887 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
4888 /* Make the loop variable start at 0. */
4889 loop->from[n] = gfc_index_zero_node;
4894 for (loop = loop->nested; loop; loop = loop->next)
4895 set_loop_bounds (loop);
4899 /* Initialize the scalarization loop. Creates the loop variables. Determines
4900 the range of the loop variables. Creates a temporary if required.
4901 Also generates code for scalar expressions which have been
4902 moved outside the loop. */
4905 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4910 set_loop_bounds (loop);
4912 /* Add all the scalar code that can be taken out of the loops.
4913 This may include calculating the loop bounds, so do it before
4914 allocating the temporary. */
4915 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4917 tmp_ss = loop->temp_ss;
4918 /* If we want a temporary then create it. */
4921 gfc_ss_info *tmp_ss_info;
4923 tmp_ss_info = tmp_ss->info;
4924 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4925 gcc_assert (loop->parent == NULL);
4927 /* Make absolutely sure that this is a complete type. */
4928 if (tmp_ss_info->string_length)
4929 tmp_ss_info->data.temp.type
4930 = gfc_get_character_type_len_for_eltype
4931 (TREE_TYPE (tmp_ss_info->data.temp.type),
4932 tmp_ss_info->string_length);
4934 tmp = tmp_ss_info->data.temp.type;
4935 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4936 tmp_ss_info->type = GFC_SS_SECTION;
4938 gcc_assert (tmp_ss->dimen != 0);
4940 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4941 NULL_TREE, false, true, false, where);
4944 /* For array parameters we don't have loop variables, so don't calculate the
4946 if (!loop->array_parameter)
4947 gfc_set_delta (loop);
4951 /* Calculates how to transform from loop variables to array indices for each
4952 array: once loop bounds are chosen, sets the difference (DELTA field) between
4953 loop bounds and array reference bounds, for each array info. */
4956 gfc_set_delta (gfc_loopinfo *loop)
4958 gfc_ss *ss, **loopspec;
4959 gfc_array_info *info;
4963 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4965 loopspec = loop->specloop;
4967 /* Calculate the translation from loop variables to array indices. */
4968 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4970 gfc_ss_type ss_type;
4972 ss_type = ss->info->type;
4973 if (ss_type != GFC_SS_SECTION
4974 && ss_type != GFC_SS_COMPONENT
4975 && ss_type != GFC_SS_CONSTRUCTOR)
4978 info = &ss->info->data.array;
4980 for (n = 0; n < ss->dimen; n++)
4982 /* If we are specifying the range the delta is already set. */
4983 if (loopspec[n] != ss)
4987 /* Calculate the offset relative to the loop variable.
4988 First multiply by the stride. */
4989 tmp = loop->from[n];
4990 if (!integer_onep (info->stride[dim]))
4991 tmp = fold_build2_loc (input_location, MULT_EXPR,
4992 gfc_array_index_type,
4993 tmp, info->stride[dim]);
4995 /* Then subtract this from our starting value. */
4996 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4997 gfc_array_index_type,
4998 info->start[dim], tmp);
5000 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5005 for (loop = loop->nested; loop; loop = loop->next)
5006 gfc_set_delta (loop);
5010 /* Calculate the size of a given array dimension from the bounds. This
5011 is simply (ubound - lbound + 1) if this expression is positive
5012 or 0 if it is negative (pick either one if it is zero). Optionally
5013 (if or_expr is present) OR the (expression != 0) condition to it. */
5016 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5021 /* Calculate (ubound - lbound + 1). */
5022 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5024 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5025 gfc_index_one_node);
5027 /* Check whether the size for this dimension is negative. */
5028 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
5029 gfc_index_zero_node);
5030 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5031 gfc_index_zero_node, res);
5033 /* Build OR expression. */
5035 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5036 boolean_type_node, *or_expr, cond);
5042 /* For an array descriptor, get the total number of elements. This is just
5043 the product of the extents along from_dim to to_dim. */
5046 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
5051 res = gfc_index_one_node;
5053 for (dim = from_dim; dim < to_dim; ++dim)
5059 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
5060 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
5062 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5063 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5071 /* Full size of an array. */
5074 gfc_conv_descriptor_size (tree desc, int rank)
5076 return gfc_conv_descriptor_size_1 (desc, 0, rank);
5080 /* Size of a coarray for all dimensions but the last. */
5083 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
5085 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
5089 /* Fills in an array descriptor, and returns the size of the array.
5090 The size will be a simple_val, ie a variable or a constant. Also
5091 calculates the offset of the base. The pointer argument overflow,
5092 which should be of integer type, will increase in value if overflow
5093 occurs during the size calculation. Returns the size of the array.
5097 for (n = 0; n < rank; n++)
5099 a.lbound[n] = specified_lower_bound;
5100 offset = offset + a.lbond[n] * stride;
5102 a.ubound[n] = specified_upper_bound;
5103 a.stride[n] = stride;
5104 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5105 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5106 stride = stride * size;
5108 for (n = rank; n < rank+corank; n++)
5109 (Set lcobound/ucobound as above.)
5110 element_size = sizeof (array element);
5113 stride = (size_t) stride;
5114 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5115 stride = stride * element_size;
5121 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
5122 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
5123 stmtblock_t * descriptor_block, tree * overflow,
5124 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
5125 tree expr3_desc, bool e3_is_array_constr, gfc_expr *expr)
5138 stmtblock_t thenblock;
5139 stmtblock_t elseblock;
5144 type = TREE_TYPE (descriptor);
5146 stride = gfc_index_one_node;
5147 offset = gfc_index_zero_node;
5149 /* Set the dtype before the alloc, because registration of coarrays needs
5151 if (expr->ts.type == BT_CHARACTER
5152 && expr->ts.deferred
5153 && VAR_P (expr->ts.u.cl->backend_decl))
5155 type = gfc_typenode_for_spec (&expr->ts);
5156 tmp = gfc_conv_descriptor_dtype (descriptor);
5157 gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5161 tmp = gfc_conv_descriptor_dtype (descriptor);
5162 gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
5165 or_expr = boolean_false_node;
5167 for (n = 0; n < rank; n++)
5172 /* We have 3 possibilities for determining the size of the array:
5173 lower == NULL => lbound = 1, ubound = upper[n]
5174 upper[n] = NULL => lbound = 1, ubound = lower[n]
5175 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
5178 /* Set lower bound. */
5179 gfc_init_se (&se, NULL);
5180 if (expr3_desc != NULL_TREE)
5182 if (e3_is_array_constr)
5183 /* The lbound of a constant array [] starts at zero, but when
5184 allocating it, the standard expects the array to start at
5186 se.expr = gfc_index_one_node;
5188 se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
5191 else if (lower == NULL)
5192 se.expr = gfc_index_one_node;
5195 gcc_assert (lower[n]);
5198 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5199 gfc_add_block_to_block (pblock, &se.pre);
5203 se.expr = gfc_index_one_node;
5207 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5208 gfc_rank_cst[n], se.expr);
5209 conv_lbound = se.expr;
5211 /* Work out the offset for this component. */
5212 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5214 offset = fold_build2_loc (input_location, MINUS_EXPR,
5215 gfc_array_index_type, offset, tmp);
5217 /* Set upper bound. */
5218 gfc_init_se (&se, NULL);
5219 if (expr3_desc != NULL_TREE)
5221 if (e3_is_array_constr)
5223 /* The lbound of a constant array [] starts at zero, but when
5224 allocating it, the standard expects the array to start at
5225 one. Therefore fix the upper bound to be
5226 (desc.ubound - desc.lbound)+ 1. */
5227 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5228 gfc_array_index_type,
5229 gfc_conv_descriptor_ubound_get (
5230 expr3_desc, gfc_rank_cst[n]),
5231 gfc_conv_descriptor_lbound_get (
5232 expr3_desc, gfc_rank_cst[n]));
5233 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5234 gfc_array_index_type, tmp,
5235 gfc_index_one_node);
5236 se.expr = gfc_evaluate_now (tmp, pblock);
5239 se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
5244 gcc_assert (ubound);
5245 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5246 gfc_add_block_to_block (pblock, &se.pre);
5247 if (ubound->expr_type == EXPR_FUNCTION)
5248 se.expr = gfc_evaluate_now (se.expr, pblock);
5250 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5251 gfc_rank_cst[n], se.expr);
5252 conv_ubound = se.expr;
5254 /* Store the stride. */
5255 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
5256 gfc_rank_cst[n], stride);
5258 /* Calculate size and check whether extent is negative. */
5259 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
5260 size = gfc_evaluate_now (size, pblock);
5262 /* Check whether multiplying the stride by the number of
5263 elements in this dimension would overflow. We must also check
5264 whether the current dimension has zero size in order to avoid
5267 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5268 gfc_array_index_type,
5269 fold_convert (gfc_array_index_type,
5270 TYPE_MAX_VALUE (gfc_array_index_type)),
5272 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5273 boolean_type_node, tmp, stride),
5274 PRED_FORTRAN_OVERFLOW);
5275 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5276 integer_one_node, integer_zero_node);
5277 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5278 boolean_type_node, size,
5279 gfc_index_zero_node),
5280 PRED_FORTRAN_SIZE_ZERO);
5281 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5282 integer_zero_node, tmp);
5283 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5285 *overflow = gfc_evaluate_now (tmp, pblock);
5287 /* Multiply the stride by the number of elements in this dimension. */
5288 stride = fold_build2_loc (input_location, MULT_EXPR,
5289 gfc_array_index_type, stride, size);
5290 stride = gfc_evaluate_now (stride, pblock);
5293 for (n = rank; n < rank + corank; n++)
5297 /* Set lower bound. */
5298 gfc_init_se (&se, NULL);
5299 if (lower == NULL || lower[n] == NULL)
5301 gcc_assert (n == rank + corank - 1);
5302 se.expr = gfc_index_one_node;
5306 if (ubound || n == rank + corank - 1)
5308 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5309 gfc_add_block_to_block (pblock, &se.pre);
5313 se.expr = gfc_index_one_node;
5317 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5318 gfc_rank_cst[n], se.expr);
5320 if (n < rank + corank - 1)
5322 gfc_init_se (&se, NULL);
5323 gcc_assert (ubound);
5324 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5325 gfc_add_block_to_block (pblock, &se.pre);
5326 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5327 gfc_rank_cst[n], se.expr);
5331 /* The stride is the number of elements in the array, so multiply by the
5332 size of an element to get the total size. Obviously, if there is a
5333 SOURCE expression (expr3) we must use its element size. */
5334 if (expr3_elem_size != NULL_TREE)
5335 tmp = expr3_elem_size;
5336 else if (expr3 != NULL)
5338 if (expr3->ts.type == BT_CLASS)
5341 gfc_expr *sz = gfc_copy_expr (expr3);
5342 gfc_add_vptr_component (sz);
5343 gfc_add_size_component (sz);
5344 gfc_init_se (&se_sz, NULL);
5345 gfc_conv_expr (&se_sz, sz);
5351 tmp = gfc_typenode_for_spec (&expr3->ts);
5352 tmp = TYPE_SIZE_UNIT (tmp);
5356 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5358 /* Convert to size_t. */
5359 element_size = fold_convert (size_type_node, tmp);
5362 return element_size;
5364 *nelems = gfc_evaluate_now (stride, pblock);
5365 stride = fold_convert (size_type_node, stride);
5367 /* First check for overflow. Since an array of type character can
5368 have zero element_size, we must check for that before
5370 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5372 TYPE_MAX_VALUE (size_type_node), element_size);
5373 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5374 boolean_type_node, tmp, stride),
5375 PRED_FORTRAN_OVERFLOW);
5376 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5377 integer_one_node, integer_zero_node);
5378 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5379 boolean_type_node, element_size,
5380 build_int_cst (size_type_node, 0)),
5381 PRED_FORTRAN_SIZE_ZERO);
5382 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5383 integer_zero_node, tmp);
5384 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5386 *overflow = gfc_evaluate_now (tmp, pblock);
5388 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5389 stride, element_size);
5391 if (poffset != NULL)
5393 offset = gfc_evaluate_now (offset, pblock);
5397 if (integer_zerop (or_expr))
5399 if (integer_onep (or_expr))
5400 return build_int_cst (size_type_node, 0);
5402 var = gfc_create_var (TREE_TYPE (size), "size");
5403 gfc_start_block (&thenblock);
5404 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
5405 thencase = gfc_finish_block (&thenblock);
5407 gfc_start_block (&elseblock);
5408 gfc_add_modify (&elseblock, var, size);
5409 elsecase = gfc_finish_block (&elseblock);
5411 tmp = gfc_evaluate_now (or_expr, pblock);
5412 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
5413 gfc_add_expr_to_block (pblock, tmp);
5419 /* Retrieve the last ref from the chain. This routine is specific to
5420 gfc_array_allocate ()'s needs. */
5423 retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
5425 gfc_ref *ref, *prev_ref;
5428 /* Prevent warnings for uninitialized variables. */
5429 prev_ref = *prev_ref_in;
5430 while (ref && ref->next != NULL)
5432 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
5433 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
5438 if (ref == NULL || ref->type != REF_ARRAY)
5442 *prev_ref_in = prev_ref;
5446 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5447 the work for an ALLOCATE statement. */
5451 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
5452 tree errlen, tree label_finish, tree expr3_elem_size,
5453 tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
5454 bool e3_is_array_constr)
5458 tree offset = NULL_TREE;
5459 tree token = NULL_TREE;
5462 tree error = NULL_TREE;
5463 tree overflow; /* Boolean storing whether size calculation overflows. */
5464 tree var_overflow = NULL_TREE;
5466 tree set_descriptor;
5467 stmtblock_t set_descriptor_block;
5468 stmtblock_t elseblock;
5471 gfc_ref *ref, *prev_ref = NULL, *coref;
5472 bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
5473 non_ulimate_coarray_ptr_comp;
5477 /* Find the last reference in the chain. */
5478 if (!retrieve_last_ref (&ref, &prev_ref))
5481 /* Take the allocatable and coarray properties solely from the expr-ref's
5482 attributes and not from source=-expression. */
5485 allocatable = expr->symtree->n.sym->attr.allocatable;
5486 dimension = expr->symtree->n.sym->attr.dimension;
5487 non_ulimate_coarray_ptr_comp = false;
5491 allocatable = prev_ref->u.c.component->attr.allocatable;
5492 /* Pointer components in coarrayed derived types must be treated
5493 specially in that they are registered without a check if the are
5494 already associated. This does not hold for ultimate coarray
5496 non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
5497 && !prev_ref->u.c.component->attr.codimension);
5498 dimension = prev_ref->u.c.component->attr.dimension;
5501 /* For allocatable/pointer arrays in derived types, one of the refs has to be
5502 a coarray. In this case it does not matter whether we are on this_image
5505 for (coref = expr->ref; coref; coref = coref->next)
5506 if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
5513 gcc_assert (coarray);
5515 if (ref->u.ar.type == AR_FULL && expr3 != NULL)
5517 gfc_ref *old_ref = ref;
5518 /* F08:C633: Array shape from expr3. */
5521 /* Find the last reference in the chain. */
5522 if (!retrieve_last_ref (&ref, &prev_ref))
5524 if (expr3->expr_type == EXPR_FUNCTION
5525 && gfc_expr_attr (expr3).dimension)
5530 alloc_w_e3_arr_spec = true;
5533 /* Figure out the size of the array. */
5534 switch (ref->u.ar.type)
5540 upper = ref->u.ar.start;
5546 lower = ref->u.ar.start;
5547 upper = ref->u.ar.end;
5551 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
5552 || alloc_w_e3_arr_spec);
5554 lower = ref->u.ar.as->lower;
5555 upper = ref->u.ar.as->upper;
5563 overflow = integer_zero_node;
5565 gfc_init_block (&set_descriptor_block);
5566 /* Take the corank only from the actual ref and not from the coref. The
5567 later will mislead the generation of the array dimensions for allocatable/
5568 pointer components in derived types. */
5569 size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
5570 : ref->u.ar.as->rank,
5571 coarray ? ref->u.ar.as->corank : 0,
5572 &offset, lower, upper,
5573 &se->pre, &set_descriptor_block, &overflow,
5574 expr3_elem_size, nelems, expr3, e3_arr_desc,
5575 e3_is_array_constr, expr);
5579 var_overflow = gfc_create_var (integer_type_node, "overflow");
5580 gfc_add_modify (&se->pre, var_overflow, overflow);
5582 if (status == NULL_TREE)
5584 /* Generate the block of code handling overflow. */
5585 msg = gfc_build_addr_expr (pchar_type_node,
5586 gfc_build_localized_cstring_const
5587 ("Integer overflow when calculating the amount of "
5588 "memory to allocate"));
5589 error = build_call_expr_loc (input_location,
5590 gfor_fndecl_runtime_error, 1, msg);
5594 tree status_type = TREE_TYPE (status);
5595 stmtblock_t set_status_block;
5597 gfc_start_block (&set_status_block);
5598 gfc_add_modify (&set_status_block, status,
5599 build_int_cst (status_type, LIBERROR_ALLOCATION));
5600 error = gfc_finish_block (&set_status_block);
5604 gfc_start_block (&elseblock);
5606 /* Allocate memory to store the data. */
5607 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5608 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5610 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
5612 pointer = non_ulimate_coarray_ptr_comp ? se->expr
5613 : gfc_conv_descriptor_data_get (se->expr);
5614 token = gfc_conv_descriptor_token (se->expr);
5615 token = gfc_build_addr_expr (NULL_TREE, token);
5618 pointer = gfc_conv_descriptor_data_get (se->expr);
5619 STRIP_NOPS (pointer);
5621 /* The allocatable variant takes the old pointer as first argument. */
5623 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5624 status, errmsg, errlen, label_finish, expr,
5625 coref != NULL ? coref->u.ar.as->corank : 0);
5626 else if (non_ulimate_coarray_ptr_comp && token)
5627 /* The token is set only for GFC_FCOARRAY_LIB mode. */
5628 gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
5630 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
5632 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5636 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5637 boolean_type_node, var_overflow, integer_zero_node),
5638 PRED_FORTRAN_OVERFLOW);
5639 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5640 error, gfc_finish_block (&elseblock));
5643 tmp = gfc_finish_block (&elseblock);
5645 gfc_add_expr_to_block (&se->pre, tmp);
5647 /* Update the array descriptors. */
5649 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
5651 set_descriptor = gfc_finish_block (&set_descriptor_block);
5652 if (status != NULL_TREE)
5654 cond = fold_build2_loc (input_location, EQ_EXPR,
5655 boolean_type_node, status,
5656 build_int_cst (TREE_TYPE (status), 0));
5657 gfc_add_expr_to_block (&se->pre,
5658 fold_build3_loc (input_location, COND_EXPR, void_type_node,
5661 build_empty_stmt (input_location)));
5664 gfc_add_expr_to_block (&se->pre, set_descriptor);
5670 /* Create an array constructor from an initialization expression.
5671 We assume the frontend already did any expansions and conversions. */
5674 gfc_conv_array_initializer (tree type, gfc_expr * expr)
5681 vec<constructor_elt, va_gc> *v = NULL;
5683 if (expr->expr_type == EXPR_VARIABLE
5684 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5685 && expr->symtree->n.sym->value)
5686 expr = expr->symtree->n.sym->value;
5688 switch (expr->expr_type)
5691 case EXPR_STRUCTURE:
5692 /* A single scalar or derived type value. Create an array with all
5693 elements equal to that value. */
5694 gfc_init_se (&se, NULL);
5696 if (expr->expr_type == EXPR_CONSTANT)
5697 gfc_conv_constant (&se, expr);
5699 gfc_conv_structure (&se, expr, 1);
5701 wtmp = wi::to_offset (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) + 1;
5702 /* This will probably eat buckets of memory for large arrays. */
5705 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
5711 /* Create a vector of all the elements. */
5712 for (c = gfc_constructor_first (expr->value.constructor);
5713 c; c = gfc_constructor_next (c))
5717 /* Problems occur when we get something like
5718 integer :: a(lots) = (/(i, i=1, lots)/) */
5719 gfc_fatal_error ("The number of elements in the array "
5720 "constructor at %L requires an increase of "
5721 "the allowed %d upper limit. See "
5722 "%<-fmax-array-constructor%> option",
5723 &expr->where, flag_max_array_constructor);
5726 if (mpz_cmp_si (c->offset, 0) != 0)
5727 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5731 if (mpz_cmp_si (c->repeat, 1) > 0)
5737 mpz_add (maxval, c->offset, c->repeat);
5738 mpz_sub_ui (maxval, maxval, 1);
5739 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5740 if (mpz_cmp_si (c->offset, 0) != 0)
5742 mpz_add_ui (maxval, c->offset, 1);
5743 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5746 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5748 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
5754 gfc_init_se (&se, NULL);
5755 switch (c->expr->expr_type)
5758 gfc_conv_constant (&se, c->expr);
5761 case EXPR_STRUCTURE:
5762 gfc_conv_structure (&se, c->expr, 1);
5766 /* Catch those occasional beasts that do not simplify
5767 for one reason or another, assuming that if they are
5768 standard defying the frontend will catch them. */
5769 gfc_conv_expr (&se, c->expr);
5773 if (range == NULL_TREE)
5774 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5777 if (index != NULL_TREE)
5778 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5779 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
5785 return gfc_build_null_descriptor (type);
5791 /* Create a constructor from the list of elements. */
5792 tmp = build_constructor (type, v);
5793 TREE_CONSTANT (tmp) = 1;
5798 /* Generate code to evaluate non-constant coarray cobounds. */
5801 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
5802 const gfc_symbol *sym)
5810 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
5812 for (dim = as->rank; dim < as->rank + as->corank; dim++)
5814 /* Evaluate non-constant array bound expressions. */
5815 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5816 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5818 gfc_init_se (&se, NULL);
5819 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5820 gfc_add_block_to_block (pblock, &se.pre);
5821 gfc_add_modify (pblock, lbound, se.expr);
5823 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5824 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5826 gfc_init_se (&se, NULL);
5827 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5828 gfc_add_block_to_block (pblock, &se.pre);
5829 gfc_add_modify (pblock, ubound, se.expr);
5835 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5836 returns the size (in elements) of the array. */
5839 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
5840 stmtblock_t * pblock)
5853 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
5855 size = gfc_index_one_node;
5856 offset = gfc_index_zero_node;
5857 for (dim = 0; dim < as->rank; dim++)
5859 /* Evaluate non-constant array bound expressions. */
5860 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5861 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5863 gfc_init_se (&se, NULL);
5864 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5865 gfc_add_block_to_block (pblock, &se.pre);
5866 gfc_add_modify (pblock, lbound, se.expr);
5868 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5869 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5871 gfc_init_se (&se, NULL);
5872 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5873 gfc_add_block_to_block (pblock, &se.pre);
5874 gfc_add_modify (pblock, ubound, se.expr);
5876 /* The offset of this dimension. offset = offset - lbound * stride. */
5877 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5879 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5882 /* The size of this dimension, and the stride of the next. */
5883 if (dim + 1 < as->rank)
5884 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5886 stride = GFC_TYPE_ARRAY_SIZE (type);
5888 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5890 /* Calculate stride = size * (ubound + 1 - lbound). */
5891 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5892 gfc_array_index_type,
5893 gfc_index_one_node, lbound);
5894 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5895 gfc_array_index_type, ubound, tmp);
5896 tmp = fold_build2_loc (input_location, MULT_EXPR,
5897 gfc_array_index_type, size, tmp);
5899 gfc_add_modify (pblock, stride, tmp);
5901 stride = gfc_evaluate_now (tmp, pblock);
5903 /* Make sure that negative size arrays are translated
5904 to being zero size. */
5905 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5906 stride, gfc_index_zero_node);
5907 tmp = fold_build3_loc (input_location, COND_EXPR,
5908 gfc_array_index_type, tmp,
5909 stride, gfc_index_zero_node);
5910 gfc_add_modify (pblock, stride, tmp);
5916 gfc_trans_array_cobounds (type, pblock, sym);
5917 gfc_trans_vla_type_sizes (sym, pblock);
5924 /* Generate code to initialize/allocate an array variable. */
5927 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5928 gfc_wrapped_block * block)
5932 tree tmp = NULL_TREE;
5939 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5941 /* Do nothing for USEd variables. */
5942 if (sym->attr.use_assoc)
5945 type = TREE_TYPE (decl);
5946 gcc_assert (GFC_ARRAY_TYPE_P (type));
5947 onstack = TREE_CODE (type) != POINTER_TYPE;
5949 gfc_init_block (&init);
5951 /* Evaluate character string length. */
5952 if (sym->ts.type == BT_CHARACTER
5953 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5955 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5957 gfc_trans_vla_type_sizes (sym, &init);
5959 /* Emit a DECL_EXPR for this variable, which will cause the
5960 gimplifier to allocate storage, and all that good stuff. */
5961 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5962 gfc_add_expr_to_block (&init, tmp);
5967 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5971 type = TREE_TYPE (type);
5973 gcc_assert (!sym->attr.use_assoc);
5974 gcc_assert (!TREE_STATIC (decl));
5975 gcc_assert (!sym->module);
5977 if (sym->ts.type == BT_CHARACTER
5978 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5979 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5981 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5983 /* Don't actually allocate space for Cray Pointees. */
5984 if (sym->attr.cray_pointee)
5986 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
5987 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5989 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5993 if (flag_stack_arrays)
5995 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5996 space = build_decl (sym->declared_at.lb->location,
5997 VAR_DECL, create_tmp_var_name ("A"),
5998 TREE_TYPE (TREE_TYPE (decl)));
5999 gfc_trans_vla_type_sizes (sym, &init);
6003 /* The size is the number of elements in the array, so multiply by the
6004 size of an element to get the total size. */
6005 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6006 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6007 size, fold_convert (gfc_array_index_type, tmp));
6009 /* Allocate memory to hold the data. */
6010 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
6011 gfc_add_modify (&init, decl, tmp);
6013 /* Free the temporary. */
6014 tmp = gfc_call_free (decl);
6018 /* Set offset of the array. */
6019 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6020 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6022 /* Automatic arrays should not have initializers. */
6023 gcc_assert (!sym->value);
6025 inittree = gfc_finish_block (&init);
6032 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
6033 where also space is located. */
6034 gfc_init_block (&init);
6035 tmp = fold_build1_loc (input_location, DECL_EXPR,
6036 TREE_TYPE (space), space);
6037 gfc_add_expr_to_block (&init, tmp);
6038 addr = fold_build1_loc (sym->declared_at.lb->location,
6039 ADDR_EXPR, TREE_TYPE (decl), space);
6040 gfc_add_modify (&init, decl, addr);
6041 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6044 gfc_add_init_cleanup (block, inittree, tmp);
6048 /* Generate entry and exit code for g77 calling convention arrays. */
6051 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
6061 gfc_save_backend_locus (&loc);
6062 gfc_set_backend_locus (&sym->declared_at);
6064 /* Descriptor type. */
6065 parm = sym->backend_decl;
6066 type = TREE_TYPE (parm);
6067 gcc_assert (GFC_ARRAY_TYPE_P (type));
6069 gfc_start_block (&init);
6071 if (sym->ts.type == BT_CHARACTER
6072 && VAR_P (sym->ts.u.cl->backend_decl))
6073 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6075 /* Evaluate the bounds of the array. */
6076 gfc_trans_array_bounds (type, sym, &offset, &init);
6078 /* Set the offset. */
6079 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6080 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6082 /* Set the pointer itself if we aren't using the parameter directly. */
6083 if (TREE_CODE (parm) != PARM_DECL)
6085 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
6086 gfc_add_modify (&init, parm, tmp);
6088 stmt = gfc_finish_block (&init);
6090 gfc_restore_backend_locus (&loc);
6092 /* Add the initialization code to the start of the function. */
6094 if (sym->attr.optional || sym->attr.not_always_present)
6096 tmp = gfc_conv_expr_present (sym);
6097 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6100 gfc_add_init_cleanup (block, stmt, NULL_TREE);
6104 /* Modify the descriptor of an array parameter so that it has the
6105 correct lower bound. Also move the upper bound accordingly.
6106 If the array is not packed, it will be copied into a temporary.
6107 For each dimension we set the new lower and upper bounds. Then we copy the
6108 stride and calculate the offset for this dimension. We also work out
6109 what the stride of a packed array would be, and see it the two match.
6110 If the array need repacking, we set the stride to the values we just
6111 calculated, recalculate the offset and copy the array data.
6112 Code is also added to copy the data back at the end of the function.
6116 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
6117 gfc_wrapped_block * block)
6124 tree stmtInit, stmtCleanup;
6131 tree stride, stride2;
6141 bool is_classarray = IS_CLASS_ARRAY (sym);
6143 /* Do nothing for pointer and allocatable arrays. */
6144 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
6145 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
6146 || sym->attr.allocatable
6147 || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
6150 if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
6152 gfc_trans_g77_array (sym, block);
6157 gfc_save_backend_locus (&loc);
6158 /* loc.nextc is not set by save_backend_locus but the location routines
6160 if (loc.nextc == NULL)
6161 loc.nextc = loc.lb->line;
6162 gfc_set_backend_locus (&sym->declared_at);
6164 /* Descriptor type. */
6165 type = TREE_TYPE (tmpdesc);
6166 gcc_assert (GFC_ARRAY_TYPE_P (type));
6167 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6169 /* For a class array the dummy array descriptor is in the _class
6171 dumdesc = gfc_class_data_get (dumdesc);
6173 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
6174 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6175 gfc_start_block (&init);
6177 if (sym->ts.type == BT_CHARACTER
6178 && VAR_P (sym->ts.u.cl->backend_decl))
6179 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6181 checkparm = (as->type == AS_EXPLICIT
6182 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
6184 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
6185 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
6187 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
6189 /* For non-constant shape arrays we only check if the first dimension
6190 is contiguous. Repacking higher dimensions wouldn't gain us
6191 anything as we still don't know the array stride. */
6192 partial = gfc_create_var (boolean_type_node, "partial");
6193 TREE_USED (partial) = 1;
6194 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6195 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
6196 gfc_index_one_node);
6197 gfc_add_modify (&init, partial, tmp);
6200 partial = NULL_TREE;
6202 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
6203 here, however I think it does the right thing. */
6206 /* Set the first stride. */
6207 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
6208 stride = gfc_evaluate_now (stride, &init);
6210 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6211 stride, gfc_index_zero_node);
6212 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6213 tmp, gfc_index_one_node, stride);
6214 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
6215 gfc_add_modify (&init, stride, tmp);
6217 /* Allow the user to disable array repacking. */
6218 stmt_unpacked = NULL_TREE;
6222 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
6223 /* A library call to repack the array if necessary. */
6224 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6225 stmt_unpacked = build_call_expr_loc (input_location,
6226 gfor_fndecl_in_pack, 1, tmp);
6228 stride = gfc_index_one_node;
6230 if (warn_array_temporaries)
6231 gfc_warning (OPT_Warray_temporaries,
6232 "Creating array temporary at %L", &loc);
6235 /* This is for the case where the array data is used directly without
6236 calling the repack function. */
6237 if (no_repack || partial != NULL_TREE)
6238 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
6240 stmt_packed = NULL_TREE;
6242 /* Assign the data pointer. */
6243 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6245 /* Don't repack unknown shape arrays when the first stride is 1. */
6246 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
6247 partial, stmt_packed, stmt_unpacked);
6250 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
6251 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
6253 offset = gfc_index_zero_node;
6254 size = gfc_index_one_node;
6256 /* Evaluate the bounds of the array. */
6257 for (n = 0; n < as->rank; n++)
6259 if (checkparm || !as->upper[n])
6261 /* Get the bounds of the actual parameter. */
6262 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
6263 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
6267 dubound = NULL_TREE;
6268 dlbound = NULL_TREE;
6271 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
6272 if (!INTEGER_CST_P (lbound))
6274 gfc_init_se (&se, NULL);
6275 gfc_conv_expr_type (&se, as->lower[n],
6276 gfc_array_index_type);
6277 gfc_add_block_to_block (&init, &se.pre);
6278 gfc_add_modify (&init, lbound, se.expr);
6281 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
6282 /* Set the desired upper bound. */
6285 /* We know what we want the upper bound to be. */
6286 if (!INTEGER_CST_P (ubound))
6288 gfc_init_se (&se, NULL);
6289 gfc_conv_expr_type (&se, as->upper[n],
6290 gfc_array_index_type);
6291 gfc_add_block_to_block (&init, &se.pre);
6292 gfc_add_modify (&init, ubound, se.expr);
6295 /* Check the sizes match. */
6298 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
6302 temp = fold_build2_loc (input_location, MINUS_EXPR,
6303 gfc_array_index_type, ubound, lbound);
6304 temp = fold_build2_loc (input_location, PLUS_EXPR,
6305 gfc_array_index_type,
6306 gfc_index_one_node, temp);
6307 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
6308 gfc_array_index_type, dubound,
6310 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
6311 gfc_array_index_type,
6312 gfc_index_one_node, stride2);
6313 tmp = fold_build2_loc (input_location, NE_EXPR,
6314 gfc_array_index_type, temp, stride2);
6315 msg = xasprintf ("Dimension %d of array '%s' has extent "
6316 "%%ld instead of %%ld", n+1, sym->name);
6318 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
6319 fold_convert (long_integer_type_node, temp),
6320 fold_convert (long_integer_type_node, stride2));
6327 /* For assumed shape arrays move the upper bound by the same amount
6328 as the lower bound. */
6329 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6330 gfc_array_index_type, dubound, dlbound);
6331 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6332 gfc_array_index_type, tmp, lbound);
6333 gfc_add_modify (&init, ubound, tmp);
6335 /* The offset of this dimension. offset = offset - lbound * stride. */
6336 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6338 offset = fold_build2_loc (input_location, MINUS_EXPR,
6339 gfc_array_index_type, offset, tmp);
6341 /* The size of this dimension, and the stride of the next. */
6342 if (n + 1 < as->rank)
6344 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
6346 if (no_repack || partial != NULL_TREE)
6348 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
6350 /* Figure out the stride if not a known constant. */
6351 if (!INTEGER_CST_P (stride))
6354 stmt_packed = NULL_TREE;
6357 /* Calculate stride = size * (ubound + 1 - lbound). */
6358 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6359 gfc_array_index_type,
6360 gfc_index_one_node, lbound);
6361 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6362 gfc_array_index_type, ubound, tmp);
6363 size = fold_build2_loc (input_location, MULT_EXPR,
6364 gfc_array_index_type, size, tmp);
6368 /* Assign the stride. */
6369 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6370 tmp = fold_build3_loc (input_location, COND_EXPR,
6371 gfc_array_index_type, partial,
6372 stmt_unpacked, stmt_packed);
6374 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
6375 gfc_add_modify (&init, stride, tmp);
6380 stride = GFC_TYPE_ARRAY_SIZE (type);
6382 if (stride && !INTEGER_CST_P (stride))
6384 /* Calculate size = stride * (ubound + 1 - lbound). */
6385 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6386 gfc_array_index_type,
6387 gfc_index_one_node, lbound);
6388 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6389 gfc_array_index_type,
6391 tmp = fold_build2_loc (input_location, MULT_EXPR,
6392 gfc_array_index_type,
6393 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
6394 gfc_add_modify (&init, stride, tmp);
6399 gfc_trans_array_cobounds (type, &init, sym);
6401 /* Set the offset. */
6402 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6403 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6405 gfc_trans_vla_type_sizes (sym, &init);
6407 stmtInit = gfc_finish_block (&init);
6409 /* Only do the entry/initialization code if the arg is present. */
6410 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6411 optional_arg = (sym->attr.optional
6412 || (sym->ns->proc_name->attr.entry_master
6413 && sym->attr.dummy));
6416 tmp = gfc_conv_expr_present (sym);
6417 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
6418 build_empty_stmt (input_location));
6423 stmtCleanup = NULL_TREE;
6426 stmtblock_t cleanup;
6427 gfc_start_block (&cleanup);
6429 if (sym->attr.intent != INTENT_IN)
6431 /* Copy the data back. */
6432 tmp = build_call_expr_loc (input_location,
6433 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
6434 gfc_add_expr_to_block (&cleanup, tmp);
6437 /* Free the temporary. */
6438 tmp = gfc_call_free (tmpdesc);
6439 gfc_add_expr_to_block (&cleanup, tmp);
6441 stmtCleanup = gfc_finish_block (&cleanup);
6443 /* Only do the cleanup if the array was repacked. */
6445 /* For a class array the dummy array descriptor is in the _class
6447 tmp = gfc_class_data_get (dumdesc);
6449 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
6450 tmp = gfc_conv_descriptor_data_get (tmp);
6451 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6453 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6454 build_empty_stmt (input_location));
6458 tmp = gfc_conv_expr_present (sym);
6459 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6460 build_empty_stmt (input_location));
6464 /* We don't need to free any memory allocated by internal_pack as it will
6465 be freed at the end of the function by pop_context. */
6466 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
6468 gfc_restore_backend_locus (&loc);
6472 /* Calculate the overall offset, including subreferences. */
6474 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
6475 bool subref, gfc_expr *expr)
6485 /* If offset is NULL and this is not a subreferenced array, there is
6487 if (offset == NULL_TREE)
6490 offset = gfc_index_zero_node;
6495 tmp = build_array_ref (desc, offset, NULL, NULL);
6497 /* Offset the data pointer for pointer assignments from arrays with
6498 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6501 /* Go past the array reference. */
6502 for (ref = expr->ref; ref; ref = ref->next)
6503 if (ref->type == REF_ARRAY &&
6504 ref->u.ar.type != AR_ELEMENT)
6510 /* Calculate the offset for each subsequent subreference. */
6511 for (; ref; ref = ref->next)
6516 field = ref->u.c.component->backend_decl;
6517 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6518 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6520 tmp, field, NULL_TREE);
6524 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6525 gfc_init_se (&start, NULL);
6526 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6527 gfc_add_block_to_block (block, &start.pre);
6528 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6532 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6533 && ref->u.ar.type == AR_ELEMENT);
6535 /* TODO - Add bounds checking. */
6536 stride = gfc_index_one_node;
6537 index = gfc_index_zero_node;
6538 for (n = 0; n < ref->u.ar.dimen; n++)
6543 /* Update the index. */
6544 gfc_init_se (&start, NULL);
6545 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6546 itmp = gfc_evaluate_now (start.expr, block);
6547 gfc_init_se (&start, NULL);
6548 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6549 jtmp = gfc_evaluate_now (start.expr, block);
6550 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6551 gfc_array_index_type, itmp, jtmp);
6552 itmp = fold_build2_loc (input_location, MULT_EXPR,
6553 gfc_array_index_type, itmp, stride);
6554 index = fold_build2_loc (input_location, PLUS_EXPR,
6555 gfc_array_index_type, itmp, index);
6556 index = gfc_evaluate_now (index, block);
6558 /* Update the stride. */
6559 gfc_init_se (&start, NULL);
6560 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6561 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6562 gfc_array_index_type, start.expr,
6564 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6565 gfc_array_index_type,
6566 gfc_index_one_node, itmp);
6567 stride = fold_build2_loc (input_location, MULT_EXPR,
6568 gfc_array_index_type, stride, itmp);
6569 stride = gfc_evaluate_now (stride, block);
6572 /* Apply the index to obtain the array element. */
6573 tmp = gfc_build_array_ref (tmp, index, NULL);
6583 /* Set the target data pointer. */
6584 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6585 gfc_conv_descriptor_data_set (block, parm, offset);
6589 /* gfc_conv_expr_descriptor needs the string length an expression
6590 so that the size of the temporary can be obtained. This is done
6591 by adding up the string lengths of all the elements in the
6592 expression. Function with non-constant expressions have their
6593 string lengths mapped onto the actual arguments using the
6594 interface mapping machinery in trans-expr.c. */
6596 get_array_charlen (gfc_expr *expr, gfc_se *se)
6598 gfc_interface_mapping mapping;
6599 gfc_formal_arglist *formal;
6600 gfc_actual_arglist *arg;
6603 if (expr->ts.u.cl->length
6604 && gfc_is_constant_expr (expr->ts.u.cl->length))
6606 if (!expr->ts.u.cl->backend_decl)
6607 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6611 switch (expr->expr_type)
6614 get_array_charlen (expr->value.op.op1, se);
6616 /* For parentheses the expression ts.u.cl is identical. */
6617 if (expr->value.op.op == INTRINSIC_PARENTHESES)
6620 expr->ts.u.cl->backend_decl =
6621 gfc_create_var (gfc_charlen_type_node, "sln");
6623 if (expr->value.op.op2)
6625 get_array_charlen (expr->value.op.op2, se);
6627 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
6629 /* Add the string lengths and assign them to the expression
6630 string length backend declaration. */
6631 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6632 fold_build2_loc (input_location, PLUS_EXPR,
6633 gfc_charlen_type_node,
6634 expr->value.op.op1->ts.u.cl->backend_decl,
6635 expr->value.op.op2->ts.u.cl->backend_decl));
6638 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6639 expr->value.op.op1->ts.u.cl->backend_decl);
6643 if (expr->value.function.esym == NULL
6644 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6646 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6650 /* Map expressions involving the dummy arguments onto the actual
6651 argument expressions. */
6652 gfc_init_interface_mapping (&mapping);
6653 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
6654 arg = expr->value.function.actual;
6656 /* Set se = NULL in the calls to the interface mapping, to suppress any
6658 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
6663 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
6666 gfc_init_se (&tse, NULL);
6668 /* Build the expression for the character length and convert it. */
6669 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
6671 gfc_add_block_to_block (&se->pre, &tse.pre);
6672 gfc_add_block_to_block (&se->post, &tse.post);
6673 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
6674 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
6675 gfc_charlen_type_node, tse.expr,
6676 build_int_cst (gfc_charlen_type_node, 0));
6677 expr->ts.u.cl->backend_decl = tse.expr;
6678 gfc_free_interface_mapping (&mapping);
6682 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6688 /* Helper function to check dimensions. */
6690 transposed_dims (gfc_ss *ss)
6694 for (n = 0; n < ss->dimen; n++)
6695 if (ss->dim[n] != n)
6701 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6702 AR_FULL, suitable for the scalarizer. */
6705 walk_coarray (gfc_expr *e)
6709 gcc_assert (gfc_get_corank (e) > 0);
6711 ss = gfc_walk_expr (e);
6713 /* Fix scalar coarray. */
6714 if (ss == gfc_ss_terminator)
6721 if (ref->type == REF_ARRAY
6722 && ref->u.ar.codimen > 0)
6728 gcc_assert (ref != NULL);
6729 if (ref->u.ar.type == AR_ELEMENT)
6730 ref->u.ar.type = AR_SECTION;
6731 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
6738 /* Convert an array for passing as an actual argument. Expressions and
6739 vector subscripts are evaluated and stored in a temporary, which is then
6740 passed. For whole arrays the descriptor is passed. For array sections
6741 a modified copy of the descriptor is passed, but using the original data.
6743 This function is also used for array pointer assignments, and there
6746 - se->want_pointer && !se->direct_byref
6747 EXPR is an actual argument. On exit, se->expr contains a
6748 pointer to the array descriptor.
6750 - !se->want_pointer && !se->direct_byref
6751 EXPR is an actual argument to an intrinsic function or the
6752 left-hand side of a pointer assignment. On exit, se->expr
6753 contains the descriptor for EXPR.
6755 - !se->want_pointer && se->direct_byref
6756 EXPR is the right-hand side of a pointer assignment and
6757 se->expr is the descriptor for the previously-evaluated
6758 left-hand side. The function creates an assignment from
6762 The se->force_tmp flag disables the non-copying descriptor optimization
6763 that is used for transpose. It may be used in cases where there is an
6764 alias between the transpose argument and another argument in the same
6768 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
6771 gfc_ss_type ss_type;
6772 gfc_ss_info *ss_info;
6774 gfc_array_info *info;
6783 bool subref_array_target = false;
6784 gfc_expr *arg, *ss_expr;
6786 if (se->want_coarray)
6787 ss = walk_coarray (expr);
6789 ss = gfc_walk_expr (expr);
6791 gcc_assert (ss != NULL);
6792 gcc_assert (ss != gfc_ss_terminator);
6795 ss_type = ss_info->type;
6796 ss_expr = ss_info->expr;
6798 /* Special case: TRANSPOSE which needs no temporary. */
6799 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
6800 && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
6802 /* This is a call to transpose which has already been handled by the
6803 scalarizer, so that we just need to get its argument's descriptor. */
6804 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6805 expr = expr->value.function.actual->expr;
6808 /* Special case things we know we can pass easily. */
6809 switch (expr->expr_type)
6812 /* If we have a linear array section, we can pass it directly.
6813 Otherwise we need to copy it into a temporary. */
6815 gcc_assert (ss_type == GFC_SS_SECTION);
6816 gcc_assert (ss_expr == expr);
6817 info = &ss_info->data.array;
6819 /* Get the descriptor for the array. */
6820 gfc_conv_ss_descriptor (&se->pre, ss, 0);
6821 desc = info->descriptor;
6823 subref_array_target = se->direct_byref && is_subref_array (expr);
6824 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
6825 && !subref_array_target;
6832 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6834 /* Create a new descriptor if the array doesn't have one. */
6837 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
6839 else if (se->direct_byref)
6842 full = gfc_full_array_ref_p (info->ref, NULL);
6844 if (full && !transposed_dims (ss))
6846 if (se->direct_byref && !se->byref_noassign)
6848 /* Copy the descriptor for pointer assignments. */
6849 gfc_add_modify (&se->pre, se->expr, desc);
6851 /* Add any offsets from subreferences. */
6852 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
6853 subref_array_target, expr);
6855 else if (se->want_pointer)
6857 /* We pass full arrays directly. This means that pointers and
6858 allocatable arrays should also work. */
6859 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6866 if (expr->ts.type == BT_CHARACTER)
6867 se->string_length = gfc_get_expr_charlen (expr);
6869 gfc_free_ss_chain (ss);
6875 /* A transformational function return value will be a temporary
6876 array descriptor. We still need to go through the scalarizer
6877 to create the descriptor. Elemental functions are handled as
6878 arbitrary expressions, i.e. copy to a temporary. */
6880 if (se->direct_byref)
6882 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
6884 /* For pointer assignments pass the descriptor directly. */
6888 gcc_assert (se->ss == ss);
6889 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6890 gfc_conv_expr (se, expr);
6891 gfc_free_ss_chain (ss);
6895 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
6897 if (ss_expr != expr)
6898 /* Elemental function. */
6899 gcc_assert ((expr->value.function.esym != NULL
6900 && expr->value.function.esym->attr.elemental)
6901 || (expr->value.function.isym != NULL
6902 && expr->value.function.isym->elemental)
6903 || gfc_inline_intrinsic_function_p (expr));
6905 gcc_assert (ss_type == GFC_SS_INTRINSIC);
6908 if (expr->ts.type == BT_CHARACTER
6909 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6910 get_array_charlen (expr, se);
6916 /* Transformational function. */
6917 info = &ss_info->data.array;
6923 /* Constant array constructors don't need a temporary. */
6924 if (ss_type == GFC_SS_CONSTRUCTOR
6925 && expr->ts.type != BT_CHARACTER
6926 && gfc_constant_array_constructor_p (expr->value.constructor))
6929 info = &ss_info->data.array;
6939 /* Something complicated. Copy it into a temporary. */
6945 /* If we are creating a temporary, we don't need to bother about aliases
6950 gfc_init_loopinfo (&loop);
6952 /* Associate the SS with the loop. */
6953 gfc_add_ss_to_loop (&loop, ss);
6955 /* Tell the scalarizer not to bother creating loop variables, etc. */
6957 loop.array_parameter = 1;
6959 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6960 gcc_assert (!se->direct_byref);
6962 /* Setup the scalarizing loops and bounds. */
6963 gfc_conv_ss_startstride (&loop);
6967 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6968 get_array_charlen (expr, se);
6970 /* Tell the scalarizer to make a temporary. */
6971 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6972 ((expr->ts.type == BT_CHARACTER)
6973 ? expr->ts.u.cl->backend_decl
6977 se->string_length = loop.temp_ss->info->string_length;
6978 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6979 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6982 gfc_conv_loop_setup (&loop, & expr->where);
6986 /* Copy into a temporary and pass that. We don't need to copy the data
6987 back because expressions and vector subscripts must be INTENT_IN. */
6988 /* TODO: Optimize passing function return values. */
6993 /* Start the copying loops. */
6994 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6995 gfc_mark_ss_chain_used (ss, 1);
6996 gfc_start_scalarized_body (&loop, &block);
6998 /* Copy each data element. */
6999 gfc_init_se (&lse, NULL);
7000 gfc_copy_loopinfo_to_se (&lse, &loop);
7001 gfc_init_se (&rse, NULL);
7002 gfc_copy_loopinfo_to_se (&rse, &loop);
7004 lse.ss = loop.temp_ss;
7007 gfc_conv_scalarized_array_ref (&lse, NULL);
7008 if (expr->ts.type == BT_CHARACTER)
7010 gfc_conv_expr (&rse, expr);
7011 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
7012 rse.expr = build_fold_indirect_ref_loc (input_location,
7016 gfc_conv_expr_val (&rse, expr);
7018 gfc_add_block_to_block (&block, &rse.pre);
7019 gfc_add_block_to_block (&block, &lse.pre);
7021 lse.string_length = rse.string_length;
7023 deep_copy = !se->data_not_needed
7024 && (expr->expr_type == EXPR_VARIABLE
7025 || expr->expr_type == EXPR_ARRAY);
7026 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
7028 gfc_add_expr_to_block (&block, tmp);
7030 /* Finish the copying loops. */
7031 gfc_trans_scalarizing_loops (&loop, &block);
7033 desc = loop.temp_ss->info->data.array.descriptor;
7035 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
7037 desc = info->descriptor;
7038 se->string_length = ss_info->string_length;
7042 /* We pass sections without copying to a temporary. Make a new
7043 descriptor and point it at the section we want. The loop variable
7044 limits will be the limits of the section.
7045 A function may decide to repack the array to speed up access, but
7046 we're not bothered about that here. */
7047 int dim, ndim, codim;
7054 bool onebased = false, rank_remap;
7056 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
7057 rank_remap = ss->dimen < ndim;
7059 if (se->want_coarray)
7061 gfc_array_ref *ar = &info->ref->u.ar;
7063 codim = gfc_get_corank (expr);
7064 for (n = 0; n < codim - 1; n++)
7066 /* Make sure we are not lost somehow. */
7067 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
7069 /* Make sure the call to gfc_conv_section_startstride won't
7070 generate unnecessary code to calculate stride. */
7071 gcc_assert (ar->stride[n + ndim] == NULL);
7073 gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
7074 loop.from[n + loop.dimen] = info->start[n + ndim];
7075 loop.to[n + loop.dimen] = info->end[n + ndim];
7078 gcc_assert (n == codim - 1);
7079 evaluate_bound (&loop.pre, info->start, ar->start,
7080 info->descriptor, n + ndim, true,
7081 ar->as->type == AS_DEFERRED);
7082 loop.from[n + loop.dimen] = info->start[n + ndim];
7087 /* Set the string_length for a character array. */
7088 if (expr->ts.type == BT_CHARACTER)
7089 se->string_length = gfc_get_expr_charlen (expr);
7091 /* If we have an array section or are assigning make sure that
7092 the lower bound is 1. References to the full
7093 array should otherwise keep the original bounds. */
7094 if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
7095 for (dim = 0; dim < loop.dimen; dim++)
7096 if (!integer_onep (loop.from[dim]))
7098 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7099 gfc_array_index_type, gfc_index_one_node,
7101 loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
7102 gfc_array_index_type,
7104 loop.from[dim] = gfc_index_one_node;
7107 desc = info->descriptor;
7108 if (se->direct_byref && !se->byref_noassign)
7110 /* For pointer assignments we fill in the destination. */
7112 parmtype = TREE_TYPE (parm);
7116 /* Otherwise make a new one. */
7117 parmtype = gfc_get_element_type (TREE_TYPE (desc));
7118 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
7119 loop.from, loop.to, 0,
7120 GFC_ARRAY_UNKNOWN, false);
7121 parm = gfc_create_var (parmtype, "parm");
7123 /* When expression is a class object, then add the class' handle to
7125 if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
7127 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
7130 /* class_expr can be NULL, when no _class ref is in expr.
7131 We must not fix this here with a gfc_fix_class_ref (). */
7134 gfc_init_se (&classse, NULL);
7135 gfc_conv_expr (&classse, class_expr);
7136 gfc_free_expr (class_expr);
7138 gcc_assert (classse.pre.head == NULL_TREE
7139 && classse.post.head == NULL_TREE);
7140 gfc_allocate_lang_decl (parm);
7141 GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
7146 offset = gfc_index_zero_node;
7148 /* The following can be somewhat confusing. We have two
7149 descriptors, a new one and the original array.
7150 {parm, parmtype, dim} refer to the new one.
7151 {desc, type, n, loop} refer to the original, which maybe
7152 a descriptorless array.
7153 The bounds of the scalarization are the bounds of the section.
7154 We don't have to worry about numeric overflows when calculating
7155 the offsets because all elements are within the array data. */
7157 /* Set the dtype. */
7158 tmp = gfc_conv_descriptor_dtype (parm);
7159 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
7161 /* Set offset for assignments to pointer only to zero if it is not
7163 if ((se->direct_byref || se->use_offset)
7164 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7165 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7166 base = gfc_index_zero_node;
7167 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7168 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
7172 for (n = 0; n < ndim; n++)
7174 stride = gfc_conv_array_stride (desc, n);
7176 /* Work out the offset. */
7178 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7180 gcc_assert (info->subscript[n]
7181 && info->subscript[n]->info->type == GFC_SS_SCALAR);
7182 start = info->subscript[n]->info->data.scalar.value;
7186 /* Evaluate and remember the start of the section. */
7187 start = info->start[n];
7188 stride = gfc_evaluate_now (stride, &loop.pre);
7191 tmp = gfc_conv_array_lbound (desc, n);
7192 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
7194 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
7196 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
7200 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
7202 /* For elemental dimensions, we only need the offset. */
7206 /* Vector subscripts need copying and are handled elsewhere. */
7208 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
7210 /* look for the corresponding scalarizer dimension: dim. */
7211 for (dim = 0; dim < ndim; dim++)
7212 if (ss->dim[dim] == n)
7215 /* loop exited early: the DIM being looked for has been found. */
7216 gcc_assert (dim < ndim);
7218 /* Set the new lower bound. */
7219 from = loop.from[dim];
7222 onebased = integer_onep (from);
7223 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7224 gfc_rank_cst[dim], from);
7226 /* Set the new upper bound. */
7227 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7228 gfc_rank_cst[dim], to);
7230 /* Multiply the stride by the section stride to get the
7232 stride = fold_build2_loc (input_location, MULT_EXPR,
7233 gfc_array_index_type,
7234 stride, info->stride[n]);
7236 if ((se->direct_byref || se->use_offset)
7237 && ((info->ref && info->ref->u.ar.type != AR_FULL)
7238 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
7240 base = fold_build2_loc (input_location, MINUS_EXPR,
7241 TREE_TYPE (base), base, stride);
7243 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
7246 tmp = gfc_conv_array_lbound (desc, n);
7247 toonebased = integer_onep (tmp);
7248 // lb(arr) - from (- start + 1)
7249 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7250 TREE_TYPE (base), tmp, from);
7251 if (onebased && toonebased)
7253 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7254 TREE_TYPE (base), tmp, start);
7255 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7256 TREE_TYPE (base), tmp,
7257 gfc_index_one_node);
7259 tmp = fold_build2_loc (input_location, MULT_EXPR,
7260 TREE_TYPE (base), tmp,
7261 gfc_conv_array_stride (desc, n));
7262 base = fold_build2_loc (input_location, PLUS_EXPR,
7263 TREE_TYPE (base), tmp, base);
7266 /* Store the new stride. */
7267 gfc_conv_descriptor_stride_set (&loop.pre, parm,
7268 gfc_rank_cst[dim], stride);
7271 for (n = loop.dimen; n < loop.dimen + codim; n++)
7273 from = loop.from[n];
7275 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
7276 gfc_rank_cst[n], from);
7277 if (n < loop.dimen + codim - 1)
7278 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
7279 gfc_rank_cst[n], to);
7282 if (se->data_not_needed)
7283 gfc_conv_descriptor_data_set (&loop.pre, parm,
7284 gfc_index_zero_node);
7286 /* Point the data pointer at the 1st element in the section. */
7287 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
7288 subref_array_target, expr);
7290 /* Force the offset to be -1, when the lower bound of the highest
7291 dimension is one and the symbol is present and is not a
7292 pointer/allocatable or associated. */
7293 if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7294 && !se->data_not_needed)
7295 || (se->use_offset && base != NULL_TREE))
7297 /* Set the offset depending on base. */
7298 tmp = rank_remap && !se->direct_byref ?
7299 fold_build2_loc (input_location, PLUS_EXPR,
7300 gfc_array_index_type, base,
7303 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
7305 else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
7306 && (!rank_remap || se->use_offset)
7307 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7309 gfc_conv_descriptor_offset_set (&loop.pre, parm,
7310 gfc_conv_descriptor_offset_get (desc));
7312 else if (onebased && (!rank_remap || se->use_offset)
7314 && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
7315 && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
7316 && !expr->symtree->n.sym->attr.allocatable
7317 && !expr->symtree->n.sym->attr.pointer
7318 && !expr->symtree->n.sym->attr.host_assoc
7319 && !expr->symtree->n.sym->attr.use_assoc)
7321 /* Set the offset to -1. */
7323 mpz_init_set_si (minus_one, -1);
7324 tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
7325 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
7329 /* Only the callee knows what the correct offset it, so just set
7331 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
7336 /* For class arrays add the class tree into the saved descriptor to
7337 enable getting of _vptr and the like. */
7338 if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
7339 && IS_CLASS_ARRAY (expr->symtree->n.sym))
7341 gfc_allocate_lang_decl (desc);
7342 GFC_DECL_SAVED_DESCRIPTOR (desc) =
7343 DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
7344 GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
7345 : expr->symtree->n.sym->backend_decl;
7347 else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
7348 && IS_CLASS_ARRAY (expr))
7351 gfc_allocate_lang_decl (desc);
7352 tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
7353 GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
7354 vtype = gfc_class_vptr_get (tmp);
7355 gfc_add_modify (&se->pre, vtype,
7356 gfc_build_addr_expr (TREE_TYPE (vtype),
7357 gfc_find_vtab (&expr->ts)->backend_decl));
7359 if (!se->direct_byref || se->byref_noassign)
7361 /* Get a pointer to the new descriptor. */
7362 if (se->want_pointer)
7363 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7368 gfc_add_block_to_block (&se->pre, &loop.pre);
7369 gfc_add_block_to_block (&se->post, &loop.post);
7371 /* Cleanup the scalarizer. */
7372 gfc_cleanup_loop (&loop);
7375 /* Helper function for gfc_conv_array_parameter if array size needs to be
7379 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
7382 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7383 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
7384 else if (expr->rank > 1)
7385 *size = build_call_expr_loc (input_location,
7386 gfor_fndecl_size0, 1,
7387 gfc_build_addr_expr (NULL, desc));
7390 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
7391 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
7393 *size = fold_build2_loc (input_location, MINUS_EXPR,
7394 gfc_array_index_type, ubound, lbound);
7395 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7396 *size, gfc_index_one_node);
7397 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
7398 *size, gfc_index_zero_node);
7400 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
7401 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7402 *size, fold_convert (gfc_array_index_type, elem));
7405 /* Convert an array for passing as an actual parameter. */
7406 /* TODO: Optimize passing g77 arrays. */
7409 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
7410 const gfc_symbol *fsym, const char *proc_name,
7415 tree tmp = NULL_TREE;
7417 tree parent = DECL_CONTEXT (current_function_decl);
7418 bool full_array_var;
7419 bool this_array_result;
7422 bool array_constructor;
7423 bool good_allocatable;
7424 bool ultimate_ptr_comp;
7425 bool ultimate_alloc_comp;
7430 ultimate_ptr_comp = false;
7431 ultimate_alloc_comp = false;
7433 for (ref = expr->ref; ref; ref = ref->next)
7435 if (ref->next == NULL)
7438 if (ref->type == REF_COMPONENT)
7440 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
7441 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
7445 full_array_var = false;
7448 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
7449 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
7451 sym = full_array_var ? expr->symtree->n.sym : NULL;
7453 /* The symbol should have an array specification. */
7454 gcc_assert (!sym || sym->as || ref->u.ar.as);
7456 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
7458 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
7459 expr->ts.u.cl->backend_decl = tmp;
7460 se->string_length = tmp;
7463 /* Is this the result of the enclosing procedure? */
7464 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
7465 if (this_array_result
7466 && (sym->backend_decl != current_function_decl)
7467 && (sym->backend_decl != parent))
7468 this_array_result = false;
7470 /* Passing address of the array if it is not pointer or assumed-shape. */
7471 if (full_array_var && g77 && !this_array_result
7472 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7474 tmp = gfc_get_symbol_decl (sym);
7476 if (sym->ts.type == BT_CHARACTER)
7477 se->string_length = sym->ts.u.cl->backend_decl;
7479 if (!sym->attr.pointer
7481 && sym->as->type != AS_ASSUMED_SHAPE
7482 && sym->as->type != AS_DEFERRED
7483 && sym->as->type != AS_ASSUMED_RANK
7484 && !sym->attr.allocatable)
7486 /* Some variables are declared directly, others are declared as
7487 pointers and allocated on the heap. */
7488 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
7491 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7493 array_parameter_size (tmp, expr, size);
7497 if (sym->attr.allocatable)
7499 if (sym->attr.dummy || sym->attr.result)
7501 gfc_conv_expr_descriptor (se, expr);
7505 array_parameter_size (tmp, expr, size);
7506 se->expr = gfc_conv_array_data (tmp);
7511 /* A convenient reduction in scope. */
7512 contiguous = g77 && !this_array_result && contiguous;
7514 /* There is no need to pack and unpack the array, if it is contiguous
7515 and not a deferred- or assumed-shape array, or if it is simply
7517 no_pack = ((sym && sym->as
7518 && !sym->attr.pointer
7519 && sym->as->type != AS_DEFERRED
7520 && sym->as->type != AS_ASSUMED_RANK
7521 && sym->as->type != AS_ASSUMED_SHAPE)
7523 (ref && ref->u.ar.as
7524 && ref->u.ar.as->type != AS_DEFERRED
7525 && ref->u.ar.as->type != AS_ASSUMED_RANK
7526 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
7528 gfc_is_simply_contiguous (expr, false, true));
7530 no_pack = contiguous && no_pack;
7532 /* Array constructors are always contiguous and do not need packing. */
7533 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
7535 /* Same is true of contiguous sections from allocatable variables. */
7536 good_allocatable = contiguous
7538 && expr->symtree->n.sym->attr.allocatable;
7540 /* Or ultimate allocatable components. */
7541 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
7543 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
7545 gfc_conv_expr_descriptor (se, expr);
7546 /* Deallocate the allocatable components of structures that are
7548 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
7549 && expr->ts.u.derived->attr.alloc_comp
7550 && expr->expr_type != EXPR_VARIABLE)
7552 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
7554 /* The components shall be deallocated before their containing entity. */
7555 gfc_prepend_expr_to_block (&se->post, tmp);
7557 if (expr->ts.type == BT_CHARACTER)
7558 se->string_length = expr->ts.u.cl->backend_decl;
7560 array_parameter_size (se->expr, expr, size);
7561 se->expr = gfc_conv_array_data (se->expr);
7565 if (this_array_result)
7567 /* Result of the enclosing function. */
7568 gfc_conv_expr_descriptor (se, expr);
7570 array_parameter_size (se->expr, expr, size);
7571 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7573 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
7574 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
7575 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
7582 /* Every other type of array. */
7583 se->want_pointer = 1;
7584 gfc_conv_expr_descriptor (se, expr);
7586 array_parameter_size (build_fold_indirect_ref_loc (input_location,
7591 /* Deallocate the allocatable components of structures that are
7592 not variable, for descriptorless arguments.
7593 Arguments with a descriptor are handled in gfc_conv_procedure_call. */
7594 if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
7595 && expr->ts.u.derived->attr.alloc_comp
7596 && expr->expr_type != EXPR_VARIABLE)
7598 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
7599 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
7601 /* The components shall be deallocated before their containing entity. */
7602 gfc_prepend_expr_to_block (&se->post, tmp);
7605 if (g77 || (fsym && fsym->attr.contiguous
7606 && !gfc_is_simply_contiguous (expr, false, true)))
7608 tree origptr = NULL_TREE;
7612 /* For contiguous arrays, save the original value of the descriptor. */
7615 origptr = gfc_create_var (pvoid_type_node, "origptr");
7616 tmp = build_fold_indirect_ref_loc (input_location, desc);
7617 tmp = gfc_conv_array_data (tmp);
7618 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7619 TREE_TYPE (origptr), origptr,
7620 fold_convert (TREE_TYPE (origptr), tmp));
7621 gfc_add_expr_to_block (&se->pre, tmp);
7624 /* Repack the array. */
7625 if (warn_array_temporaries)
7628 gfc_warning (OPT_Warray_temporaries,
7629 "Creating array temporary at %L for argument %qs",
7630 &expr->where, fsym->name);
7632 gfc_warning (OPT_Warray_temporaries,
7633 "Creating array temporary at %L", &expr->where);
7636 ptr = build_call_expr_loc (input_location,
7637 gfor_fndecl_in_pack, 1, desc);
7639 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7641 tmp = gfc_conv_expr_present (sym);
7642 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
7643 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
7644 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
7647 ptr = gfc_evaluate_now (ptr, &se->pre);
7649 /* Use the packed data for the actual argument, except for contiguous arrays,
7650 where the descriptor's data component is set. */
7655 tmp = build_fold_indirect_ref_loc (input_location, desc);
7657 gfc_ss * ss = gfc_walk_expr (expr);
7658 if (!transposed_dims (ss))
7659 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
7662 tree old_field, new_field;
7664 /* The original descriptor has transposed dims so we can't reuse
7665 it directly; we have to create a new one. */
7666 tree old_desc = tmp;
7667 tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
7669 old_field = gfc_conv_descriptor_dtype (old_desc);
7670 new_field = gfc_conv_descriptor_dtype (new_desc);
7671 gfc_add_modify (&se->pre, new_field, old_field);
7673 old_field = gfc_conv_descriptor_offset (old_desc);
7674 new_field = gfc_conv_descriptor_offset (new_desc);
7675 gfc_add_modify (&se->pre, new_field, old_field);
7677 for (int i = 0; i < expr->rank; i++)
7679 old_field = gfc_conv_descriptor_dimension (old_desc,
7680 gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
7681 new_field = gfc_conv_descriptor_dimension (new_desc,
7683 gfc_add_modify (&se->pre, new_field, old_field);
7686 if (flag_coarray == GFC_FCOARRAY_LIB
7687 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
7688 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
7689 == GFC_ARRAY_ALLOCATABLE)
7691 old_field = gfc_conv_descriptor_token (old_desc);
7692 new_field = gfc_conv_descriptor_token (new_desc);
7693 gfc_add_modify (&se->pre, new_field, old_field);
7696 gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
7697 se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
7702 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
7706 if (fsym && proc_name)
7707 msg = xasprintf ("An array temporary was created for argument "
7708 "'%s' of procedure '%s'", fsym->name, proc_name);
7710 msg = xasprintf ("An array temporary was created");
7712 tmp = build_fold_indirect_ref_loc (input_location,
7714 tmp = gfc_conv_array_data (tmp);
7715 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7716 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7718 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7719 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7721 gfc_conv_expr_present (sym), tmp);
7723 gfc_trans_runtime_check (false, true, tmp, &se->pre,
7728 gfc_start_block (&block);
7730 /* Copy the data back. */
7731 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
7733 tmp = build_call_expr_loc (input_location,
7734 gfor_fndecl_in_unpack, 2, desc, ptr);
7735 gfc_add_expr_to_block (&block, tmp);
7738 /* Free the temporary. */
7739 tmp = gfc_call_free (ptr);
7740 gfc_add_expr_to_block (&block, tmp);
7742 stmt = gfc_finish_block (&block);
7744 gfc_init_block (&block);
7745 /* Only if it was repacked. This code needs to be executed before the
7746 loop cleanup code. */
7747 tmp = build_fold_indirect_ref_loc (input_location,
7749 tmp = gfc_conv_array_data (tmp);
7750 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7751 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7753 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7754 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7756 gfc_conv_expr_present (sym), tmp);
7758 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
7760 gfc_add_expr_to_block (&block, tmp);
7761 gfc_add_block_to_block (&block, &se->post);
7763 gfc_init_block (&se->post);
7765 /* Reset the descriptor pointer. */
7768 tmp = build_fold_indirect_ref_loc (input_location, desc);
7769 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
7772 gfc_add_block_to_block (&se->post, &block);
7777 /* This helper function calculates the size in words of a full array. */
7780 gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
7785 idx = gfc_rank_cst[rank - 1];
7786 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
7787 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
7788 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7790 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7791 tmp, gfc_index_one_node);
7792 tmp = gfc_evaluate_now (tmp, block);
7794 nelems = gfc_conv_descriptor_stride_get (decl, idx);
7795 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7797 return gfc_evaluate_now (tmp, block);
7801 /* Allocate dest to the same size as src, and copy src -> dest.
7802 If no_malloc is set, only the copy is done. */
7805 duplicate_allocatable (tree dest, tree src, tree type, int rank,
7806 bool no_malloc, bool no_memcpy, tree str_sz,
7807 tree add_when_allocated)
7816 /* If the source is null, set the destination to null. Then,
7817 allocate memory to the destination. */
7818 gfc_init_block (&block);
7820 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7822 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
7823 null_data = gfc_finish_block (&block);
7825 gfc_init_block (&block);
7826 if (str_sz != NULL_TREE)
7829 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7833 tmp = gfc_call_malloc (&block, type, size);
7834 gfc_add_modify (&block, dest, fold_convert (type, tmp));
7839 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7840 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
7841 fold_convert (size_type_node, size));
7842 gfc_add_expr_to_block (&block, tmp);
7847 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7848 null_data = gfc_finish_block (&block);
7850 gfc_init_block (&block);
7852 nelems = gfc_full_array_size (&block, src, rank);
7854 nelems = gfc_index_one_node;
7856 if (str_sz != NULL_TREE)
7857 tmp = fold_convert (gfc_array_index_type, str_sz);
7859 tmp = fold_convert (gfc_array_index_type,
7860 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7861 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7865 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
7866 tmp = gfc_call_malloc (&block, tmp, size);
7867 gfc_conv_descriptor_data_set (&block, dest, tmp);
7870 /* We know the temporary and the value will be the same length,
7871 so can use memcpy. */
7874 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7875 tmp = build_call_expr_loc (input_location, tmp, 3,
7876 gfc_conv_descriptor_data_get (dest),
7877 gfc_conv_descriptor_data_get (src),
7878 fold_convert (size_type_node, size));
7879 gfc_add_expr_to_block (&block, tmp);
7883 gfc_add_expr_to_block (&block, add_when_allocated);
7884 tmp = gfc_finish_block (&block);
7886 /* Null the destination if the source is null; otherwise do
7887 the allocate and copy. */
7888 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
7891 null_cond = gfc_conv_descriptor_data_get (src);
7893 null_cond = convert (pvoid_type_node, null_cond);
7894 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7895 null_cond, null_pointer_node);
7896 return build3_v (COND_EXPR, null_cond, tmp, null_data);
7900 /* Allocate dest to the same size as src, and copy data src -> dest. */
7903 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
7904 tree add_when_allocated)
7906 return duplicate_allocatable (dest, src, type, rank, false, false,
7907 NULL_TREE, add_when_allocated);
7911 /* Copy data src -> dest. */
7914 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
7916 return duplicate_allocatable (dest, src, type, rank, true, false,
7917 NULL_TREE, NULL_TREE);
7920 /* Allocate dest to the same size as src, but don't copy anything. */
7923 gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
7925 return duplicate_allocatable (dest, src, type, rank, false, true,
7926 NULL_TREE, NULL_TREE);
7931 duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
7932 tree type, int rank)
7939 stmtblock_t block, globalblock;
7941 /* If the source is null, set the destination to null. Then,
7942 allocate memory to the destination. */
7943 gfc_init_block (&block);
7944 gfc_init_block (&globalblock);
7946 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7949 symbol_attribute attr;
7952 gfc_init_se (&se, NULL);
7953 dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
7954 gfc_add_block_to_block (&globalblock, &se.pre);
7955 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7957 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
7958 gfc_allocate_using_caf_lib (&block, dummy_desc, size,
7959 gfc_build_addr_expr (NULL_TREE, dest_tok),
7960 NULL_TREE, NULL_TREE, NULL_TREE,
7961 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
7962 null_data = gfc_finish_block (&block);
7964 gfc_init_block (&block);
7966 gfc_allocate_using_caf_lib (&block, dummy_desc,
7967 fold_convert (size_type_node, size),
7968 gfc_build_addr_expr (NULL_TREE, dest_tok),
7969 NULL_TREE, NULL_TREE, NULL_TREE,
7970 GFC_CAF_COARRAY_ALLOC);
7972 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7973 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
7974 fold_convert (size_type_node, size));
7975 gfc_add_expr_to_block (&block, tmp);
7979 /* Set the rank or unitialized memory access may be reported. */
7980 tmp = gfc_conv_descriptor_dtype (dest);
7981 gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
7984 nelems = gfc_full_array_size (&block, src, rank);
7986 nelems = integer_one_node;
7988 tmp = fold_convert (size_type_node,
7989 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7990 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7991 fold_convert (size_type_node, nelems), tmp);
7993 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7994 gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
7996 gfc_build_addr_expr (NULL_TREE, dest_tok),
7997 NULL_TREE, NULL_TREE, NULL_TREE,
7998 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
7999 null_data = gfc_finish_block (&block);
8001 gfc_init_block (&block);
8002 gfc_allocate_using_caf_lib (&block, dest,
8003 fold_convert (size_type_node, size),
8004 gfc_build_addr_expr (NULL_TREE, dest_tok),
8005 NULL_TREE, NULL_TREE, NULL_TREE,
8006 GFC_CAF_COARRAY_ALLOC);
8008 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
8009 tmp = build_call_expr_loc (input_location, tmp, 3,
8010 gfc_conv_descriptor_data_get (dest),
8011 gfc_conv_descriptor_data_get (src),
8012 fold_convert (size_type_node, size));
8013 gfc_add_expr_to_block (&block, tmp);
8016 tmp = gfc_finish_block (&block);
8018 /* Null the destination if the source is null; otherwise do
8019 the register and copy. */
8020 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
8023 null_cond = gfc_conv_descriptor_data_get (src);
8025 null_cond = convert (pvoid_type_node, null_cond);
8026 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8027 null_cond, null_pointer_node);
8028 gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
8030 return gfc_finish_block (&globalblock);
8034 /* Helper function to abstract whether coarray processing is enabled. */
8037 caf_enabled (int caf_mode)
8039 return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
8040 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
8044 /* Helper function to abstract whether coarray processing is enabled
8045 and we are in a derived type coarray. */
8048 caf_in_coarray (int caf_mode)
8050 static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
8051 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
8052 return (caf_mode & pat) == pat;
8056 /* Helper function to abstract whether coarray is to deallocate only. */
8059 gfc_caf_is_dealloc_only (int caf_mode)
8061 return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
8062 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
8066 /* Recursively traverse an object of derived type, generating code to
8067 deallocate, nullify or copy allocatable components. This is the work horse
8068 function for the functions named in this enum. */
8070 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
8071 COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
8074 structure_alloc_comps (gfc_symbol * der_type, tree decl,
8075 tree dest, int rank, int purpose, int caf_mode)
8079 stmtblock_t fnblock;
8080 stmtblock_t loopbody;
8081 stmtblock_t tmpblock;
8092 tree null_cond = NULL_TREE;
8093 tree add_when_allocated;
8094 tree dealloc_fndecl;
8098 symbol_attribute *attr;
8099 bool deallocate_called;
8101 gfc_init_block (&fnblock);
8103 decl_type = TREE_TYPE (decl);
8105 if ((POINTER_TYPE_P (decl_type))
8106 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
8108 decl = build_fold_indirect_ref_loc (input_location, decl);
8109 /* Deref dest in sync with decl, but only when it is not NULL. */
8111 dest = build_fold_indirect_ref_loc (input_location, dest);
8113 /* Update the decl_type because it got dereferenced. */
8114 decl_type = TREE_TYPE (decl);
8117 /* If this is an array of derived types with allocatable components
8118 build a loop and recursively call this function. */
8119 if (TREE_CODE (decl_type) == ARRAY_TYPE
8120 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
8122 tmp = gfc_conv_array_data (decl);
8123 var = build_fold_indirect_ref_loc (input_location, tmp);
8125 /* Get the number of elements - 1 and set the counter. */
8126 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
8128 /* Use the descriptor for an allocatable array. Since this
8129 is a full array reference, we only need the descriptor
8130 information from dimension = rank. */
8131 tmp = gfc_full_array_size (&fnblock, decl, rank);
8132 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8133 gfc_array_index_type, tmp,
8134 gfc_index_one_node);
8136 null_cond = gfc_conv_descriptor_data_get (decl);
8137 null_cond = fold_build2_loc (input_location, NE_EXPR,
8138 boolean_type_node, null_cond,
8139 build_int_cst (TREE_TYPE (null_cond), 0));
8143 /* Otherwise use the TYPE_DOMAIN information. */
8144 tmp = array_type_nelts (decl_type);
8145 tmp = fold_convert (gfc_array_index_type, tmp);
8148 /* Remember that this is, in fact, the no. of elements - 1. */
8149 nelems = gfc_evaluate_now (tmp, &fnblock);
8150 index = gfc_create_var (gfc_array_index_type, "S");
8152 /* Build the body of the loop. */
8153 gfc_init_block (&loopbody);
8155 vref = gfc_build_array_ref (var, index, NULL);
8157 if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
8158 && !caf_enabled (caf_mode))
8160 tmp = build_fold_indirect_ref_loc (input_location,
8161 gfc_conv_array_data (dest));
8162 dref = gfc_build_array_ref (tmp, index, NULL);
8163 tmp = structure_alloc_comps (der_type, vref, dref, rank,
8164 COPY_ALLOC_COMP, 0);
8167 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
8170 gfc_add_expr_to_block (&loopbody, tmp);
8172 /* Build the loop and return. */
8173 gfc_init_loopinfo (&loop);
8175 loop.from[0] = gfc_index_zero_node;
8176 loop.loopvar[0] = index;
8177 loop.to[0] = nelems;
8178 gfc_trans_scalarizing_loops (&loop, &loopbody);
8179 gfc_add_block_to_block (&fnblock, &loop.pre);
8181 tmp = gfc_finish_block (&fnblock);
8182 /* When copying allocateable components, the above implements the
8183 deep copy. Nevertheless is a deep copy only allowed, when the current
8184 component is allocated, for which code will be generated in
8185 gfc_duplicate_allocatable (), where the deep copy code is just added
8186 into the if's body, by adding tmp (the deep copy code) as last
8187 argument to gfc_duplicate_allocatable (). */
8188 if (purpose == COPY_ALLOC_COMP
8189 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8190 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
8192 else if (null_cond != NULL_TREE)
8193 tmp = build3_v (COND_EXPR, null_cond, tmp,
8194 build_empty_stmt (input_location));
8199 /* Otherwise, act on the components or recursively call self to
8200 act on a chain of components. */
8201 for (c = der_type->components; c; c = c->next)
8203 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
8204 || c->ts.type == BT_CLASS)
8205 && c->ts.u.derived->attr.alloc_comp;
8206 bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
8207 || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
8209 cdecl = c->backend_decl;
8210 ctype = TREE_TYPE (cdecl);
8214 case DEALLOCATE_ALLOC_COMP:
8216 gfc_init_block (&tmpblock);
8218 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8219 decl, cdecl, NULL_TREE);
8221 /* Shortcut to get the attributes of the component. */
8222 if (c->ts.type == BT_CLASS)
8223 attr = &CLASS_DATA (c)->attr;
8227 if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
8228 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
8229 /* Call the finalizer, which will free the memory and nullify the
8230 pointer of an array. */
8231 deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
8232 caf_enabled (caf_mode))
8235 deallocate_called = false;
8237 /* Add the _class ref for classes. */
8238 if (c->ts.type == BT_CLASS && attr->allocatable)
8239 comp = gfc_class_data_get (comp);
8241 add_when_allocated = NULL_TREE;
8242 if (cmp_has_alloc_comps
8243 && !c->attr.pointer && !c->attr.proc_pointer
8245 && !deallocate_called)
8247 /* Add checked deallocation of the components. This code is
8248 obviously added because the finalizer is not trusted to free
8250 if (c->ts.type == BT_CLASS)
8252 rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
8254 = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
8255 comp, NULL_TREE, rank, purpose,
8260 rank = c->as ? c->as->rank : 0;
8261 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
8268 if (attr->allocatable && !same_type
8269 && (!attr->codimension || caf_enabled (caf_mode)))
8271 /* Handle all types of components besides components of the
8272 same_type as the current one, because those would create an
8275 = (caf_in_coarray (caf_mode) || attr->codimension)
8276 ? (gfc_caf_is_dealloc_only (caf_mode)
8277 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8278 : GFC_CAF_COARRAY_DEREGISTER)
8279 : GFC_CAF_COARRAY_NOCOARRAY;
8281 caf_token = NULL_TREE;
8282 /* Coarray components are handled directly by
8283 deallocate_with_status. */
8284 if (!attr->codimension
8285 && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
8288 caf_token = fold_build3_loc (input_location, COMPONENT_REF,
8289 TREE_TYPE (c->caf_token),
8290 decl, c->caf_token, NULL_TREE);
8291 else if (attr->dimension && !attr->proc_pointer)
8292 caf_token = gfc_conv_descriptor_token (comp);
8294 if (attr->dimension && !attr->codimension && !attr->proc_pointer)
8295 /* When this is an array but not in conjunction with a coarray
8296 then add the data-ref. For coarray'ed arrays the data-ref
8297 is added by deallocate_with_status. */
8298 comp = gfc_conv_descriptor_data_get (comp);
8300 tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
8301 NULL_TREE, NULL_TREE, true,
8302 NULL, caf_dereg_mode,
8303 add_when_allocated, caf_token);
8305 gfc_add_expr_to_block (&tmpblock, tmp);
8307 else if (attr->allocatable && !attr->codimension
8308 && !deallocate_called)
8310 /* Case of recursive allocatable derived types. */
8314 stmtblock_t dealloc_block;
8316 gfc_init_block (&dealloc_block);
8317 if (add_when_allocated)
8318 gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
8320 /* Convert the component into a rank 1 descriptor type. */
8321 if (attr->dimension)
8323 tmp = gfc_get_element_type (TREE_TYPE (comp));
8324 ubound = gfc_full_array_size (&dealloc_block, comp,
8325 c->ts.type == BT_CLASS
8326 ? CLASS_DATA (c)->as->rank
8331 tmp = TREE_TYPE (comp);
8332 ubound = build_int_cst (gfc_array_index_type, 1);
8335 cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
8337 GFC_ARRAY_ALLOCATABLE, false);
8339 cdesc = gfc_create_var (cdesc, "cdesc");
8340 DECL_ARTIFICIAL (cdesc) = 1;
8342 gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
8343 gfc_get_dtype_rank_type (1, tmp));
8344 gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
8345 gfc_index_zero_node,
8346 gfc_index_one_node);
8347 gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
8348 gfc_index_zero_node,
8349 gfc_index_one_node);
8350 gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
8351 gfc_index_zero_node, ubound);
8353 if (attr->dimension)
8354 comp = gfc_conv_descriptor_data_get (comp);
8356 gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
8358 /* Now call the deallocator. */
8359 vtab = gfc_find_vtab (&c->ts);
8360 if (vtab->backend_decl == NULL)
8361 gfc_get_symbol_decl (vtab);
8362 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
8363 dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
8364 dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
8366 tmp = build_int_cst (TREE_TYPE (comp), 0);
8367 is_allocated = fold_build2_loc (input_location, NE_EXPR,
8368 boolean_type_node, tmp,
8370 cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
8372 tmp = build_call_expr_loc (input_location,
8375 gfc_add_expr_to_block (&dealloc_block, tmp);
8377 tmp = gfc_finish_block (&dealloc_block);
8379 tmp = fold_build3_loc (input_location, COND_EXPR,
8380 void_type_node, is_allocated, tmp,
8381 build_empty_stmt (input_location));
8383 gfc_add_expr_to_block (&tmpblock, tmp);
8385 else if (add_when_allocated)
8386 gfc_add_expr_to_block (&tmpblock, add_when_allocated);
8388 if (c->ts.type == BT_CLASS && attr->allocatable
8389 && (!attr->codimension || !caf_enabled (caf_mode)))
8391 /* Finally, reset the vptr to the declared type vtable and, if
8392 necessary reset the _len field.
8394 First recover the reference to the component and obtain
8396 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8397 decl, cdecl, NULL_TREE);
8398 tmp = gfc_class_vptr_get (comp);
8400 if (UNLIMITED_POLY (c))
8402 /* Both vptr and _len field should be nulled. */
8403 gfc_add_modify (&tmpblock, tmp,
8404 build_int_cst (TREE_TYPE (tmp), 0));
8405 tmp = gfc_class_len_get (comp);
8406 gfc_add_modify (&tmpblock, tmp,
8407 build_int_cst (TREE_TYPE (tmp), 0));
8411 /* Build the vtable address and set the vptr with it. */
8414 vtable = gfc_find_derived_vtab (c->ts.u.derived);
8415 vtab = vtable->backend_decl;
8416 if (vtab == NULL_TREE)
8417 vtab = gfc_get_symbol_decl (vtable);
8418 vtab = gfc_build_addr_expr (NULL, vtab);
8419 vtab = fold_convert (TREE_TYPE (tmp), vtab);
8420 gfc_add_modify (&tmpblock, tmp, vtab);
8424 /* Now add the deallocation of this component. */
8425 gfc_add_block_to_block (&fnblock, &tmpblock);
8428 case NULLIFY_ALLOC_COMP:
8430 - allocatable components (regular or in class)
8431 - components that have allocatable components
8432 - pointer components when in a coarray.
8433 Skip everything else especially proc_pointers, which may come
8434 coupled with the regular pointer attribute. */
8435 if (c->attr.proc_pointer
8436 || !(c->attr.allocatable || (c->ts.type == BT_CLASS
8437 && CLASS_DATA (c)->attr.allocatable)
8438 || (cmp_has_alloc_comps
8439 && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
8440 || (c->ts.type == BT_CLASS
8441 && !CLASS_DATA (c)->attr.class_pointer)))
8442 || (caf_in_coarray (caf_mode) && c->attr.pointer)))
8445 /* Process class components first, because they always have the
8446 pointer-attribute set which would be caught wrong else. */
8447 if (c->ts.type == BT_CLASS
8448 && (CLASS_DATA (c)->attr.allocatable
8449 || CLASS_DATA (c)->attr.class_pointer))
8451 /* Allocatable CLASS components. */
8452 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8453 decl, cdecl, NULL_TREE);
8455 comp = gfc_class_data_get (comp);
8456 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
8457 gfc_conv_descriptor_data_set (&fnblock, comp,
8461 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8462 void_type_node, comp,
8463 build_int_cst (TREE_TYPE (comp), 0));
8464 gfc_add_expr_to_block (&fnblock, tmp);
8466 cmp_has_alloc_comps = false;
8468 /* Coarrays need the component to be nulled before the api-call
8470 else if (c->attr.pointer || c->attr.allocatable)
8472 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8473 decl, cdecl, NULL_TREE);
8474 if (c->attr.dimension || c->attr.codimension)
8475 gfc_conv_descriptor_data_set (&fnblock, comp,
8478 gfc_add_modify (&fnblock, comp,
8479 build_int_cst (TREE_TYPE (comp), 0));
8480 if (gfc_deferred_strlen (c, &comp))
8482 comp = fold_build3_loc (input_location, COMPONENT_REF,
8484 decl, comp, NULL_TREE);
8485 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8486 TREE_TYPE (comp), comp,
8487 build_int_cst (TREE_TYPE (comp), 0));
8488 gfc_add_expr_to_block (&fnblock, tmp);
8490 cmp_has_alloc_comps = false;
8493 if (flag_coarray == GFC_FCOARRAY_LIB
8494 && (caf_in_coarray (caf_mode) || c->attr.codimension))
8496 /* Register the component with the coarray library. */
8499 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8500 decl, cdecl, NULL_TREE);
8501 if (c->attr.dimension || c->attr.codimension)
8503 /* Set the dtype, because caf_register needs it. */
8504 gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
8505 gfc_get_dtype (TREE_TYPE (comp)));
8506 tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8507 decl, cdecl, NULL_TREE);
8508 token = gfc_conv_descriptor_token (tmp);
8513 symbol_attribute attr;
8515 gfc_init_se (&se, NULL);
8516 gfc_clear_attr (&attr);
8517 token = fold_build3_loc (input_location, COMPONENT_REF,
8518 pvoid_type_node, decl, c->caf_token,
8520 comp = gfc_conv_scalar_to_descriptor (&se, comp, attr);
8521 gfc_add_block_to_block (&fnblock, &se.pre);
8524 gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
8525 gfc_build_addr_expr (NULL_TREE,
8527 NULL_TREE, NULL_TREE, NULL_TREE,
8528 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
8531 if (cmp_has_alloc_comps)
8533 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8534 decl, cdecl, NULL_TREE);
8535 rank = c->as ? c->as->rank : 0;
8536 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
8537 rank, purpose, caf_mode);
8538 gfc_add_expr_to_block (&fnblock, tmp);
8542 case REASSIGN_CAF_COMP:
8543 if (caf_enabled (caf_mode)
8544 && (c->attr.codimension
8545 || (c->ts.type == BT_CLASS
8546 && (CLASS_DATA (c)->attr.coarray_comp
8547 || caf_in_coarray (caf_mode)))
8548 || (c->ts.type == BT_DERIVED
8549 && (c->ts.u.derived->attr.coarray_comp
8550 || caf_in_coarray (caf_mode))))
8553 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8554 decl, cdecl, NULL_TREE);
8555 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8556 dest, cdecl, NULL_TREE);
8558 if (c->attr.codimension)
8560 if (c->ts.type == BT_CLASS)
8562 comp = gfc_class_data_get (comp);
8563 dcmp = gfc_class_data_get (dcmp);
8565 gfc_conv_descriptor_data_set (&fnblock, dcmp,
8566 gfc_conv_descriptor_data_get (comp));
8570 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
8571 rank, purpose, caf_mode
8572 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
8573 gfc_add_expr_to_block (&fnblock, tmp);
8578 case COPY_ALLOC_COMP:
8579 if (c->attr.pointer)
8582 /* We need source and destination components. */
8583 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
8585 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
8587 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
8589 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
8597 dst_data = gfc_class_data_get (dcmp);
8598 src_data = gfc_class_data_get (comp);
8599 size = fold_convert (size_type_node,
8600 gfc_class_vtab_size_get (comp));
8602 if (CLASS_DATA (c)->attr.dimension)
8604 nelems = gfc_conv_descriptor_size (src_data,
8605 CLASS_DATA (c)->as->rank);
8606 size = fold_build2_loc (input_location, MULT_EXPR,
8607 size_type_node, size,
8608 fold_convert (size_type_node,
8612 nelems = build_int_cst (size_type_node, 1);
8614 if (CLASS_DATA (c)->attr.dimension
8615 || CLASS_DATA (c)->attr.codimension)
8617 src_data = gfc_conv_descriptor_data_get (src_data);
8618 dst_data = gfc_conv_descriptor_data_get (dst_data);
8621 gfc_init_block (&tmpblock);
8623 /* Coarray component have to have the same allocation status and
8624 shape/type-parameter/effective-type on the LHS and RHS of an
8625 intrinsic assignment. Hence, we did not deallocated them - and
8626 do not allocate them here. */
8627 if (!CLASS_DATA (c)->attr.codimension)
8629 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
8630 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
8631 gfc_add_modify (&tmpblock, dst_data,
8632 fold_convert (TREE_TYPE (dst_data), tmp));
8635 tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
8636 UNLIMITED_POLY (c));
8637 gfc_add_expr_to_block (&tmpblock, tmp);
8638 tmp = gfc_finish_block (&tmpblock);
8640 gfc_init_block (&tmpblock);
8641 gfc_add_modify (&tmpblock, dst_data,
8642 fold_convert (TREE_TYPE (dst_data),
8643 null_pointer_node));
8644 null_data = gfc_finish_block (&tmpblock);
8646 null_cond = fold_build2_loc (input_location, NE_EXPR,
8647 boolean_type_node, src_data,
8650 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
8655 /* To implement guarded deep copy, i.e., deep copy only allocatable
8656 components that are really allocated, the deep copy code has to
8657 be generated first and then added to the if-block in
8658 gfc_duplicate_allocatable (). */
8659 if (cmp_has_alloc_comps && !c->attr.proc_pointer
8662 rank = c->as ? c->as->rank : 0;
8663 tmp = fold_convert (TREE_TYPE (dcmp), comp);
8664 gfc_add_modify (&fnblock, dcmp, tmp);
8665 add_when_allocated = structure_alloc_comps (c->ts.u.derived,
8671 add_when_allocated = NULL_TREE;
8673 if (gfc_deferred_strlen (c, &tmp))
8677 tmp = fold_build3_loc (input_location, COMPONENT_REF,
8679 decl, len, NULL_TREE);
8680 len = fold_build3_loc (input_location, COMPONENT_REF,
8682 dest, len, NULL_TREE);
8683 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8684 TREE_TYPE (len), len, tmp);
8685 gfc_add_expr_to_block (&fnblock, tmp);
8686 size = size_of_string_in_bytes (c->ts.kind, len);
8687 /* This component can not have allocatable components,
8688 therefore add_when_allocated of duplicate_allocatable ()
8690 tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
8691 false, false, size, NULL_TREE);
8692 gfc_add_expr_to_block (&fnblock, tmp);
8694 else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
8695 && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
8696 || caf_in_coarray (caf_mode)))
8698 rank = c->as ? c->as->rank : 0;
8699 if (c->attr.codimension)
8700 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
8701 else if (flag_coarray == GFC_FCOARRAY_LIB
8702 && caf_in_coarray (caf_mode))
8704 tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
8705 : fold_build3_loc (input_location,
8707 pvoid_type_node, dest,
8710 tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
8714 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
8715 add_when_allocated);
8716 gfc_add_expr_to_block (&fnblock, tmp);
8719 if (cmp_has_alloc_comps)
8720 gfc_add_expr_to_block (&fnblock, add_when_allocated);
8730 return gfc_finish_block (&fnblock);
8733 /* Recursively traverse an object of derived type, generating code to
8734 nullify allocatable components. */
8737 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
8740 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8742 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
8746 /* Recursively traverse an object of derived type, generating code to
8747 deallocate allocatable components. */
8750 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
8753 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8754 DEALLOCATE_ALLOC_COMP,
8755 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
8759 /* Recursively traverse an object of derived type, generating code to
8760 deallocate allocatable components. But do not deallocate coarrays.
8761 To be used for intrinsic assignment, which may not change the allocation
8762 status of coarrays. */
8765 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
8767 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8768 DEALLOCATE_ALLOC_COMP, 0);
8773 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
8775 return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
8776 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
8780 /* Recursively traverse an object of derived type, generating code to
8781 copy it and its allocatable components. */
8784 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
8787 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
8792 /* Recursively traverse an object of derived type, generating code to
8793 copy only its allocatable components. */
8796 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
8798 return structure_alloc_comps (der_type, decl, dest, rank,
8799 COPY_ONLY_ALLOC_COMP, 0);
8803 /* Returns the value of LBOUND for an expression. This could be broken out
8804 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8805 called by gfc_alloc_allocatable_for_assignment. */
8807 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
8812 tree cond, cond1, cond3, cond4;
8816 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8818 tmp = gfc_rank_cst[dim];
8819 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
8820 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
8821 stride = gfc_conv_descriptor_stride_get (desc, tmp);
8822 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
8824 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
8825 stride, gfc_index_zero_node);
8826 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8827 boolean_type_node, cond3, cond1);
8828 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8829 stride, gfc_index_zero_node);
8831 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8832 tmp, build_int_cst (gfc_array_index_type,
8835 cond = boolean_false_node;
8837 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8838 boolean_type_node, cond3, cond4);
8839 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8840 boolean_type_node, cond, cond1);
8842 return fold_build3_loc (input_location, COND_EXPR,
8843 gfc_array_index_type, cond,
8844 lbound, gfc_index_one_node);
8847 if (expr->expr_type == EXPR_FUNCTION)
8849 /* A conversion function, so use the argument. */
8850 gcc_assert (expr->value.function.isym
8851 && expr->value.function.isym->conversion);
8852 expr = expr->value.function.actual->expr;
8855 if (expr->expr_type == EXPR_VARIABLE)
8857 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
8858 for (ref = expr->ref; ref; ref = ref->next)
8860 if (ref->type == REF_COMPONENT
8861 && ref->u.c.component->as
8863 && ref->next->u.ar.type == AR_FULL)
8864 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
8866 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
8869 return gfc_index_one_node;
8873 /* Returns true if an expression represents an lhs that can be reallocated
8877 gfc_is_reallocatable_lhs (gfc_expr *expr)
8884 /* An allocatable class variable with no reference. */
8885 if (expr->symtree->n.sym->ts.type == BT_CLASS
8886 && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
8887 && expr->ref && expr->ref->type == REF_COMPONENT
8888 && strcmp (expr->ref->u.c.component->name, "_data") == 0
8889 && expr->ref->next == NULL)
8892 /* An allocatable variable. */
8893 if (expr->symtree->n.sym->attr.allocatable
8895 && expr->ref->type == REF_ARRAY
8896 && expr->ref->u.ar.type == AR_FULL)
8899 /* All that can be left are allocatable components. */
8900 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
8901 && expr->symtree->n.sym->ts.type != BT_CLASS)
8902 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
8905 /* Find a component ref followed by an array reference. */
8906 for (ref = expr->ref; ref; ref = ref->next)
8908 && ref->type == REF_COMPONENT
8909 && ref->next->type == REF_ARRAY
8910 && !ref->next->next)
8916 /* Return true if valid reallocatable lhs. */
8917 if (ref->u.c.component->attr.allocatable
8918 && ref->next->u.ar.type == AR_FULL)
8926 concat_str_length (gfc_expr* expr)
8933 type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
8934 len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
8935 if (len1 == NULL_TREE)
8937 if (expr->value.op.op1->expr_type == EXPR_OP)
8938 len1 = concat_str_length (expr->value.op.op1);
8939 else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
8940 len1 = build_int_cst (gfc_charlen_type_node,
8941 expr->value.op.op1->value.character.length);
8942 else if (expr->value.op.op1->ts.u.cl->length)
8944 gfc_init_se (&se, NULL);
8945 gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
8951 gfc_init_se (&se, NULL);
8952 se.want_pointer = 1;
8953 se.descriptor_only = 1;
8954 gfc_conv_expr (&se, expr->value.op.op1);
8955 len1 = se.string_length;
8959 type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
8960 len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
8961 if (len2 == NULL_TREE)
8963 if (expr->value.op.op2->expr_type == EXPR_OP)
8964 len2 = concat_str_length (expr->value.op.op2);
8965 else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
8966 len2 = build_int_cst (gfc_charlen_type_node,
8967 expr->value.op.op2->value.character.length);
8968 else if (expr->value.op.op2->ts.u.cl->length)
8970 gfc_init_se (&se, NULL);
8971 gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
8977 gfc_init_se (&se, NULL);
8978 se.want_pointer = 1;
8979 se.descriptor_only = 1;
8980 gfc_conv_expr (&se, expr->value.op.op2);
8981 len2 = se.string_length;
8985 gcc_assert(len1 && len2);
8986 len1 = fold_convert (gfc_charlen_type_node, len1);
8987 len2 = fold_convert (gfc_charlen_type_node, len2);
8989 return fold_build2_loc (input_location, PLUS_EXPR,
8990 gfc_charlen_type_node, len1, len2);
8994 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8998 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
9002 stmtblock_t realloc_block;
9003 stmtblock_t alloc_block;
9007 gfc_array_info *linfo;
9029 gfc_array_spec * as;
9030 bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
9031 && gfc_caf_attr (expr1, true).codimension);
9035 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
9036 Find the lhs expression in the loop chain and set expr1 and
9037 expr2 accordingly. */
9038 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
9041 /* Find the ss for the lhs. */
9043 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
9044 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
9046 if (lss == gfc_ss_terminator)
9048 expr1 = lss->info->expr;
9051 /* Bail out if this is not a valid allocate on assignment. */
9052 if (!gfc_is_reallocatable_lhs (expr1)
9053 || (expr2 && !expr2->rank))
9056 /* Find the ss for the lhs. */
9058 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
9059 if (lss->info->expr == expr1)
9062 if (lss == gfc_ss_terminator)
9065 linfo = &lss->info->data.array;
9067 /* Find an ss for the rhs. For operator expressions, we see the
9068 ss's for the operands. Any one of these will do. */
9070 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
9071 if (rss->info->expr != expr1 && rss != loop->temp_ss)
9074 if (expr2 && rss == gfc_ss_terminator)
9077 gfc_start_block (&fblock);
9079 /* Since the lhs is allocatable, this must be a descriptor type.
9080 Get the data and array size. */
9081 desc = linfo->descriptor;
9082 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
9083 array1 = gfc_conv_descriptor_data_get (desc);
9085 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
9086 deallocated if expr is an array of different shape or any of the
9087 corresponding length type parameter values of variable and expr
9088 differ." This assures F95 compatibility. */
9089 jump_label1 = gfc_build_label_decl (NULL_TREE);
9090 jump_label2 = gfc_build_label_decl (NULL_TREE);
9092 /* Allocate if data is NULL. */
9093 cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
9094 array1, build_int_cst (TREE_TYPE (array1), 0));
9096 if (expr1->ts.deferred)
9097 cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
9099 cond_null= gfc_evaluate_now (cond_null, &fblock);
9101 tmp = build3_v (COND_EXPR, cond_null,
9102 build1_v (GOTO_EXPR, jump_label1),
9103 build_empty_stmt (input_location));
9104 gfc_add_expr_to_block (&fblock, tmp);
9106 /* Get arrayspec if expr is a full array. */
9107 if (expr2 && expr2->expr_type == EXPR_FUNCTION
9108 && expr2->value.function.isym
9109 && expr2->value.function.isym->conversion)
9111 /* For conversion functions, take the arg. */
9112 gfc_expr *arg = expr2->value.function.actual->expr;
9113 as = gfc_get_full_arrayspec_from_expr (arg);
9116 as = gfc_get_full_arrayspec_from_expr (expr2);
9120 /* If the lhs shape is not the same as the rhs jump to setting the
9121 bounds and doing the reallocation....... */
9122 for (n = 0; n < expr1->rank; n++)
9124 /* Check the shape. */
9125 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9126 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9127 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9128 gfc_array_index_type,
9129 loop->to[n], loop->from[n]);
9130 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9131 gfc_array_index_type,
9133 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9134 gfc_array_index_type,
9136 cond = fold_build2_loc (input_location, NE_EXPR,
9138 tmp, gfc_index_zero_node);
9139 tmp = build3_v (COND_EXPR, cond,
9140 build1_v (GOTO_EXPR, jump_label1),
9141 build_empty_stmt (input_location));
9142 gfc_add_expr_to_block (&fblock, tmp);
9145 /* ....else jump past the (re)alloc code. */
9146 tmp = build1_v (GOTO_EXPR, jump_label2);
9147 gfc_add_expr_to_block (&fblock, tmp);
9149 /* Add the label to start automatic (re)allocation. */
9150 tmp = build1_v (LABEL_EXPR, jump_label1);
9151 gfc_add_expr_to_block (&fblock, tmp);
9153 /* If the lhs has not been allocated, its bounds will not have been
9154 initialized and so its size is set to zero. */
9155 size1 = gfc_create_var (gfc_array_index_type, NULL);
9156 gfc_init_block (&alloc_block);
9157 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
9158 gfc_init_block (&realloc_block);
9159 gfc_add_modify (&realloc_block, size1,
9160 gfc_conv_descriptor_size (desc, expr1->rank));
9161 tmp = build3_v (COND_EXPR, cond_null,
9162 gfc_finish_block (&alloc_block),
9163 gfc_finish_block (&realloc_block));
9164 gfc_add_expr_to_block (&fblock, tmp);
9166 /* Get the rhs size and fix it. */
9168 desc2 = rss->info->data.array.descriptor;
9172 size2 = gfc_index_one_node;
9173 for (n = 0; n < expr2->rank; n++)
9175 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9176 gfc_array_index_type,
9177 loop->to[n], loop->from[n]);
9178 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9179 gfc_array_index_type,
9180 tmp, gfc_index_one_node);
9181 size2 = fold_build2_loc (input_location, MULT_EXPR,
9182 gfc_array_index_type,
9185 size2 = gfc_evaluate_now (size2, &fblock);
9187 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
9190 /* If the lhs is deferred length, assume that the element size
9191 changes and force a reallocation. */
9192 if (expr1->ts.deferred)
9193 neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
9195 neq_size = gfc_evaluate_now (cond, &fblock);
9197 /* Deallocation of allocatable components will have to occur on
9198 reallocation. Fix the old descriptor now. */
9199 if ((expr1->ts.type == BT_DERIVED)
9200 && expr1->ts.u.derived->attr.alloc_comp)
9201 old_desc = gfc_evaluate_now (desc, &fblock);
9203 old_desc = NULL_TREE;
9205 /* Now modify the lhs descriptor and the associated scalarizer
9206 variables. F2003 7.4.1.3: "If variable is or becomes an
9207 unallocated allocatable variable, then it is allocated with each
9208 deferred type parameter equal to the corresponding type parameters
9209 of expr , with the shape of expr , and with each lower bound equal
9210 to the corresponding element of LBOUND(expr)."
9211 Reuse size1 to keep a dimension-by-dimension track of the
9212 stride of the new array. */
9213 size1 = gfc_index_one_node;
9214 offset = gfc_index_zero_node;
9216 for (n = 0; n < expr2->rank; n++)
9218 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9219 gfc_array_index_type,
9220 loop->to[n], loop->from[n]);
9221 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9222 gfc_array_index_type,
9223 tmp, gfc_index_one_node);
9225 lbound = gfc_index_one_node;
9230 lbd = get_std_lbound (expr2, desc2, n,
9231 as->type == AS_ASSUMED_SIZE);
9232 ubound = fold_build2_loc (input_location,
9234 gfc_array_index_type,
9236 ubound = fold_build2_loc (input_location,
9238 gfc_array_index_type,
9243 gfc_conv_descriptor_lbound_set (&fblock, desc,
9246 gfc_conv_descriptor_ubound_set (&fblock, desc,
9249 gfc_conv_descriptor_stride_set (&fblock, desc,
9252 lbound = gfc_conv_descriptor_lbound_get (desc,
9254 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
9255 gfc_array_index_type,
9257 offset = fold_build2_loc (input_location, MINUS_EXPR,
9258 gfc_array_index_type,
9260 size1 = fold_build2_loc (input_location, MULT_EXPR,
9261 gfc_array_index_type,
9265 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
9266 the array offset is saved and the info.offset is used for a
9267 running offset. Use the saved_offset instead. */
9268 tmp = gfc_conv_descriptor_offset (desc);
9269 gfc_add_modify (&fblock, tmp, offset);
9270 if (linfo->saved_offset
9271 && VAR_P (linfo->saved_offset))
9272 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
9274 /* Now set the deltas for the lhs. */
9275 for (n = 0; n < expr1->rank; n++)
9277 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9279 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9280 gfc_array_index_type, tmp,
9282 if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
9283 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
9286 /* Get the new lhs size in bytes. */
9287 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9289 if (expr2->ts.deferred)
9291 if (VAR_P (expr2->ts.u.cl->backend_decl))
9292 tmp = expr2->ts.u.cl->backend_decl;
9294 tmp = rss->info->string_length;
9298 tmp = expr2->ts.u.cl->backend_decl;
9299 if (!tmp && expr2->expr_type == EXPR_OP
9300 && expr2->value.op.op == INTRINSIC_CONCAT)
9302 tmp = concat_str_length (expr2);
9303 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
9305 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
9308 if (expr1->ts.u.cl->backend_decl
9309 && VAR_P (expr1->ts.u.cl->backend_decl))
9310 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
9312 gfc_add_modify (&fblock, lss->info->string_length, tmp);
9314 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
9316 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
9317 tmp = fold_build2_loc (input_location, MULT_EXPR,
9318 gfc_array_index_type, tmp,
9319 expr1->ts.u.cl->backend_decl);
9322 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9323 tmp = fold_convert (gfc_array_index_type, tmp);
9324 size2 = fold_build2_loc (input_location, MULT_EXPR,
9325 gfc_array_index_type,
9327 size2 = fold_convert (size_type_node, size2);
9328 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9329 size2, size_one_node);
9330 size2 = gfc_evaluate_now (size2, &fblock);
9332 /* For deferred character length, the 'size' field of the dtype might
9333 have changed so set the dtype. */
9334 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
9335 && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9338 tmp = gfc_conv_descriptor_dtype (desc);
9339 if (expr2->ts.u.cl->backend_decl)
9340 type = gfc_typenode_for_spec (&expr2->ts);
9342 type = gfc_typenode_for_spec (&expr1->ts);
9344 gfc_add_modify (&fblock, tmp,
9345 gfc_get_dtype_rank_type (expr1->rank,type));
9347 else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
9349 gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
9350 gfc_get_dtype (TREE_TYPE (desc)));
9353 /* Realloc expression. Note that the scalarizer uses desc.data
9354 in the array reference - (*desc.data)[<element>]. */
9355 gfc_init_block (&realloc_block);
9356 gfc_init_se (&caf_se, NULL);
9360 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
9361 if (token == NULL_TREE)
9363 tmp = gfc_get_tree_for_caf_expr (expr1);
9364 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
9365 tmp = build_fold_indirect_ref (tmp);
9366 gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
9368 token = gfc_build_addr_expr (NULL_TREE, token);
9371 gfc_add_block_to_block (&realloc_block, &caf_se.pre);
9373 if ((expr1->ts.type == BT_DERIVED)
9374 && expr1->ts.u.derived->attr.alloc_comp)
9376 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
9378 gfc_add_expr_to_block (&realloc_block, tmp);
9383 tmp = build_call_expr_loc (input_location,
9384 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
9385 fold_convert (pvoid_type_node, array1),
9387 gfc_conv_descriptor_data_set (&realloc_block,
9392 tmp = build_call_expr_loc (input_location,
9393 gfor_fndecl_caf_deregister, 5, token,
9394 build_int_cst (integer_type_node,
9395 GFC_CAF_COARRAY_DEALLOCATE_ONLY),
9396 null_pointer_node, null_pointer_node,
9398 gfc_add_expr_to_block (&realloc_block, tmp);
9399 tmp = build_call_expr_loc (input_location,
9400 gfor_fndecl_caf_register,
9402 build_int_cst (integer_type_node,
9403 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
9404 token, gfc_build_addr_expr (NULL_TREE, desc),
9405 null_pointer_node, null_pointer_node,
9407 gfc_add_expr_to_block (&realloc_block, tmp);
9410 if ((expr1->ts.type == BT_DERIVED)
9411 && expr1->ts.u.derived->attr.alloc_comp)
9413 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
9415 gfc_add_expr_to_block (&realloc_block, tmp);
9418 gfc_add_block_to_block (&realloc_block, &caf_se.post);
9419 realloc_expr = gfc_finish_block (&realloc_block);
9421 /* Only reallocate if sizes are different. */
9422 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
9423 build_empty_stmt (input_location));
9427 /* Malloc expression. */
9428 gfc_init_block (&alloc_block);
9431 tmp = build_call_expr_loc (input_location,
9432 builtin_decl_explicit (BUILT_IN_MALLOC),
9434 gfc_conv_descriptor_data_set (&alloc_block,
9439 tmp = build_call_expr_loc (input_location,
9440 gfor_fndecl_caf_register,
9442 build_int_cst (integer_type_node,
9443 GFC_CAF_COARRAY_ALLOC),
9444 token, gfc_build_addr_expr (NULL_TREE, desc),
9445 null_pointer_node, null_pointer_node,
9447 gfc_add_expr_to_block (&alloc_block, tmp);
9451 /* We already set the dtype in the case of deferred character
9453 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
9454 && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9457 tmp = gfc_conv_descriptor_dtype (desc);
9458 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9461 if ((expr1->ts.type == BT_DERIVED)
9462 && expr1->ts.u.derived->attr.alloc_comp)
9464 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
9466 gfc_add_expr_to_block (&alloc_block, tmp);
9468 alloc_expr = gfc_finish_block (&alloc_block);
9470 /* Malloc if not allocated; realloc otherwise. */
9471 tmp = build_int_cst (TREE_TYPE (array1), 0);
9472 cond = fold_build2_loc (input_location, EQ_EXPR,
9475 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
9476 gfc_add_expr_to_block (&fblock, tmp);
9478 /* Make sure that the scalarizer data pointer is updated. */
9479 if (linfo->data && VAR_P (linfo->data))
9481 tmp = gfc_conv_descriptor_data_get (desc);
9482 gfc_add_modify (&fblock, linfo->data, tmp);
9485 /* Add the exit label. */
9486 tmp = build1_v (LABEL_EXPR, jump_label2);
9487 gfc_add_expr_to_block (&fblock, tmp);
9489 return gfc_finish_block (&fblock);
9493 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
9494 Do likewise, recursively if necessary, with the allocatable components of
9498 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
9504 stmtblock_t cleanup;
9507 bool sym_has_alloc_comp, has_finalizer;
9509 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
9510 || sym->ts.type == BT_CLASS)
9511 && sym->ts.u.derived->attr.alloc_comp;
9512 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
9513 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
9515 /* Make sure the frontend gets these right. */
9516 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
9519 gfc_save_backend_locus (&loc);
9520 gfc_set_backend_locus (&sym->declared_at);
9521 gfc_init_block (&init);
9523 gcc_assert (VAR_P (sym->backend_decl)
9524 || TREE_CODE (sym->backend_decl) == PARM_DECL);
9526 if (sym->ts.type == BT_CHARACTER
9527 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
9529 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
9530 gfc_trans_vla_type_sizes (sym, &init);
9533 /* Dummy, use associated and result variables don't need anything special. */
9534 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
9536 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
9537 gfc_restore_backend_locus (&loc);
9541 descriptor = sym->backend_decl;
9543 /* Although static, derived types with default initializers and
9544 allocatable components must not be nulled wholesale; instead they
9545 are treated component by component. */
9546 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
9548 /* SAVEd variables are not freed on exit. */
9549 gfc_trans_static_array_pointer (sym);
9551 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
9552 gfc_restore_backend_locus (&loc);
9556 /* Get the descriptor type. */
9557 type = TREE_TYPE (sym->backend_decl);
9559 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
9560 && !(sym->attr.pointer || sym->attr.allocatable))
9563 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
9565 if (sym->value == NULL
9566 || !gfc_has_default_initializer (sym->ts.u.derived))
9568 rank = sym->as ? sym->as->rank : 0;
9569 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
9571 gfc_add_expr_to_block (&init, tmp);
9574 gfc_init_default_dt (sym, &init, false);
9577 else if (!GFC_DESCRIPTOR_TYPE_P (type))
9579 /* If the backend_decl is not a descriptor, we must have a pointer
9581 descriptor = build_fold_indirect_ref_loc (input_location,
9583 type = TREE_TYPE (descriptor);
9586 /* NULLIFY the data pointer, for non-saved allocatables. */
9587 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
9589 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
9590 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
9592 /* Declare the variable static so its array descriptor stays present
9593 after leaving the scope. It may still be accessed through another
9594 image. This may happen, for example, with the caf_mpi
9596 TREE_STATIC (descriptor) = 1;
9597 tmp = gfc_conv_descriptor_token (descriptor);
9598 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
9599 null_pointer_node));
9603 gfc_restore_backend_locus (&loc);
9604 gfc_init_block (&cleanup);
9606 /* Allocatable arrays need to be freed when they go out of scope.
9607 The allocatable components of pointers must not be touched. */
9608 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
9609 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
9610 && !sym->ns->proc_name->attr.is_main_program)
9613 sym->attr.referenced = 1;
9614 e = gfc_lval_expr_from_sym (sym);
9615 gfc_add_finalizer_call (&cleanup, e);
9618 else if ((!sym->attr.allocatable || !has_finalizer)
9619 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
9620 && !sym->attr.pointer && !sym->attr.save
9621 && !sym->ns->proc_name->attr.is_main_program)
9624 rank = sym->as ? sym->as->rank : 0;
9625 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
9626 gfc_add_expr_to_block (&cleanup, tmp);
9629 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
9630 && !sym->attr.save && !sym->attr.result
9631 && !sym->ns->proc_name->attr.is_main_program)
9634 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
9635 tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
9636 NULL_TREE, NULL_TREE, true, e,
9637 sym->attr.codimension
9638 ? GFC_CAF_COARRAY_DEREGISTER
9639 : GFC_CAF_COARRAY_NOCOARRAY);
9642 gfc_add_expr_to_block (&cleanup, tmp);
9645 gfc_add_init_cleanup (block, gfc_finish_block (&init),
9646 gfc_finish_block (&cleanup));
9649 /************ Expression Walking Functions ******************/
9651 /* Walk a variable reference.
9653 Possible extension - multiple component subscripts.
9654 x(:,:) = foo%a(:)%b(:)
9656 forall (i=..., j=...)
9657 x(i,j) = foo%a(j)%b(i)
9659 This adds a fair amount of complexity because you need to deal with more
9660 than one ref. Maybe handle in a similar manner to vector subscripts.
9661 Maybe not worth the effort. */
9665 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
9669 for (ref = expr->ref; ref; ref = ref->next)
9670 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
9673 return gfc_walk_array_ref (ss, expr, ref);
9678 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
9684 for (; ref; ref = ref->next)
9686 if (ref->type == REF_SUBSTRING)
9688 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
9689 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
9692 /* We're only interested in array sections from now on. */
9693 if (ref->type != REF_ARRAY)
9701 for (n = ar->dimen - 1; n >= 0; n--)
9702 ss = gfc_get_scalar_ss (ss, ar->start[n]);
9706 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
9707 newss->info->data.array.ref = ref;
9709 /* Make sure array is the same as array(:,:), this way
9710 we don't need to special case all the time. */
9711 ar->dimen = ar->as->rank;
9712 for (n = 0; n < ar->dimen; n++)
9714 ar->dimen_type[n] = DIMEN_RANGE;
9716 gcc_assert (ar->start[n] == NULL);
9717 gcc_assert (ar->end[n] == NULL);
9718 gcc_assert (ar->stride[n] == NULL);
9724 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
9725 newss->info->data.array.ref = ref;
9727 /* We add SS chains for all the subscripts in the section. */
9728 for (n = 0; n < ar->dimen; n++)
9732 switch (ar->dimen_type[n])
9735 /* Add SS for elemental (scalar) subscripts. */
9736 gcc_assert (ar->start[n]);
9737 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
9738 indexss->loop_chain = gfc_ss_terminator;
9739 newss->info->data.array.subscript[n] = indexss;
9743 /* We don't add anything for sections, just remember this
9744 dimension for later. */
9745 newss->dim[newss->dimen] = n;
9750 /* Create a GFC_SS_VECTOR index in which we can store
9751 the vector's descriptor. */
9752 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
9754 indexss->loop_chain = gfc_ss_terminator;
9755 newss->info->data.array.subscript[n] = indexss;
9756 newss->dim[newss->dimen] = n;
9761 /* We should know what sort of section it is by now. */
9765 /* We should have at least one non-elemental dimension,
9766 unless we are creating a descriptor for a (scalar) coarray. */
9767 gcc_assert (newss->dimen > 0
9768 || newss->info->data.array.ref->u.ar.as->corank > 0);
9773 /* We should know what sort of section it is by now. */
9782 /* Walk an expression operator. If only one operand of a binary expression is
9783 scalar, we must also add the scalar term to the SS chain. */
9786 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
9791 head = gfc_walk_subexpr (ss, expr->value.op.op1);
9792 if (expr->value.op.op2 == NULL)
9795 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
9797 /* All operands are scalar. Pass back and let the caller deal with it. */
9801 /* All operands require scalarization. */
9802 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
9805 /* One of the operands needs scalarization, the other is scalar.
9806 Create a gfc_ss for the scalar expression. */
9809 /* First operand is scalar. We build the chain in reverse order, so
9810 add the scalar SS after the second operand. */
9812 while (head && head->next != ss)
9814 /* Check we haven't somehow broken the chain. */
9816 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
9818 else /* head2 == head */
9820 gcc_assert (head2 == head);
9821 /* Second operand is scalar. */
9822 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
9829 /* Reverse a SS chain. */
9832 gfc_reverse_ss (gfc_ss * ss)
9837 gcc_assert (ss != NULL);
9839 head = gfc_ss_terminator;
9840 while (ss != gfc_ss_terminator)
9843 /* Check we didn't somehow break the chain. */
9844 gcc_assert (next != NULL);
9854 /* Given an expression referring to a procedure, return the symbol of its
9855 interface. We can't get the procedure symbol directly as we have to handle
9856 the case of (deferred) type-bound procedures. */
9859 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
9864 if (procedure_ref == NULL)
9867 /* Normal procedure case. */
9868 if (procedure_ref->expr_type == EXPR_FUNCTION
9869 && procedure_ref->value.function.esym)
9870 sym = procedure_ref->value.function.esym;
9872 sym = procedure_ref->symtree->n.sym;
9874 /* Typebound procedure case. */
9875 for (ref = procedure_ref->ref; ref; ref = ref->next)
9877 if (ref->type == REF_COMPONENT
9878 && ref->u.c.component->attr.proc_pointer)
9879 sym = ref->u.c.component->ts.interface;
9888 /* Walk the arguments of an elemental function.
9889 PROC_EXPR is used to check whether an argument is permitted to be absent. If
9890 it is NULL, we don't do the check and the argument is assumed to be present.
9894 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
9895 gfc_symbol *proc_ifc, gfc_ss_type type)
9897 gfc_formal_arglist *dummy_arg;
9903 head = gfc_ss_terminator;
9907 dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
9912 for (; arg; arg = arg->next)
9914 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
9917 newss = gfc_walk_subexpr (head, arg->expr);
9920 /* Scalar argument. */
9921 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
9922 newss = gfc_get_scalar_ss (head, arg->expr);
9923 newss->info->type = type;
9925 newss->info->data.scalar.dummy_arg = dummy_arg->sym;
9930 if (dummy_arg != NULL
9931 && dummy_arg->sym->attr.optional
9932 && arg->expr->expr_type == EXPR_VARIABLE
9933 && (gfc_expr_attr (arg->expr).optional
9934 || gfc_expr_attr (arg->expr).allocatable
9935 || gfc_expr_attr (arg->expr).pointer))
9936 newss->info->can_be_null_ref = true;
9942 while (tail->next != gfc_ss_terminator)
9947 if (dummy_arg != NULL)
9948 dummy_arg = dummy_arg->next;
9953 /* If all the arguments are scalar we don't need the argument SS. */
9954 gfc_free_ss_chain (head);
9959 /* Add it onto the existing chain. */
9965 /* Walk a function call. Scalar functions are passed back, and taken out of
9966 scalarization loops. For elemental functions we walk their arguments.
9967 The result of functions returning arrays is stored in a temporary outside
9968 the loop, so that the function is only called once. Hence we do not need
9969 to walk their arguments. */
9972 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
9974 gfc_intrinsic_sym *isym;
9976 gfc_component *comp = NULL;
9978 isym = expr->value.function.isym;
9980 /* Handle intrinsic functions separately. */
9982 return gfc_walk_intrinsic_function (ss, expr, isym);
9984 sym = expr->value.function.esym;
9986 sym = expr->symtree->n.sym;
9988 if (gfc_is_alloc_class_array_function (expr))
9989 return gfc_get_array_ss (ss, expr,
9990 CLASS_DATA (expr->value.function.esym->result)->as->rank,
9993 /* A function that returns arrays. */
9994 comp = gfc_get_proc_ptr_comp (expr);
9995 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
9996 || (comp && comp->attr.dimension))
9997 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
9999 /* Walk the parameters of an elemental function. For now we always pass
10001 if (sym->attr.elemental || (comp && comp->attr.elemental))
10003 gfc_ss *old_ss = ss;
10005 ss = gfc_walk_elemental_function_args (old_ss,
10006 expr->value.function.actual,
10007 gfc_get_proc_ifc_for_expr (expr),
10011 || sym->attr.proc_pointer
10012 || sym->attr.if_source != IFSRC_DECL
10013 || sym->attr.array_outer_dependency))
10014 ss->info->array_outer_dependency = 1;
10017 /* Scalar functions are OK as these are evaluated outside the scalarization
10018 loop. Pass back and let the caller deal with it. */
10023 /* An array temporary is constructed for array constructors. */
10026 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
10028 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
10032 /* Walk an expression. Add walked expressions to the head of the SS chain.
10033 A wholly scalar expression will not be added. */
10036 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
10040 switch (expr->expr_type)
10042 case EXPR_VARIABLE:
10043 head = gfc_walk_variable_expr (ss, expr);
10047 head = gfc_walk_op_expr (ss, expr);
10050 case EXPR_FUNCTION:
10051 head = gfc_walk_function_expr (ss, expr);
10054 case EXPR_CONSTANT:
10056 case EXPR_STRUCTURE:
10057 /* Pass back and let the caller deal with it. */
10061 head = gfc_walk_array_constructor (ss, expr);
10064 case EXPR_SUBSTRING:
10065 /* Pass back and let the caller deal with it. */
10069 gfc_internal_error ("bad expression type during walk (%d)",
10076 /* Entry point for expression walking.
10077 A return value equal to the passed chain means this is
10078 a scalar expression. It is up to the caller to take whatever action is
10079 necessary to translate these. */
10082 gfc_walk_expr (gfc_expr * expr)
10086 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
10087 return gfc_reverse_ss (res);