1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
26 /* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subscripts as procedure parameters.
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
63 values are automatically substituted. Note that gfc_advance_se_ss_chain
64 must be used, rather than changing the se->ss directly.
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
81 #include "coretypes.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
99 /* The contents of this structure aren't actually used, just the address. */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
105 gfc_array_dataptr_type (tree desc)
107 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
111 /* Build expressions to access the members of an array descriptor.
112 It's surprisingly easy to mess up here, so never access
113 an array descriptor by "brute force", always use these
114 functions. This also avoids problems if we change the format
115 of an array descriptor.
117 To understand these magic numbers, look at the comments
118 before gfc_build_array_type() in trans-types.c.
120 The code within these defines should be the only code which knows the format
121 of an array descriptor.
123 Any code just needing to read obtain the bounds of an array should use
124 gfc_conv_array_* rather than the following functions as these will return
125 know constant values, and work with arrays which do not have descriptors.
127 Don't forget to #undef these! */
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
171 type = TREE_TYPE (desc);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174 field = TYPE_FIELDS (type);
175 gcc_assert (DATA_FIELD == 0);
177 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
186 gfc_conv_descriptor_data_addr (tree desc)
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
197 return build_fold_addr_expr (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 (COMPONENT_REF, TREE_TYPE (field),
213 desc, field, NULL_TREE);
217 gfc_conv_descriptor_dtype (tree desc)
222 type = TREE_TYPE (desc);
223 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
225 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
226 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
228 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
229 desc, field, NULL_TREE);
233 gfc_conv_descriptor_dimension (tree desc, tree dim)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
243 gcc_assert (field != NULL_TREE
244 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
245 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
247 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
248 desc, field, NULL_TREE);
249 tmp = gfc_build_array_ref (tmp, dim, NULL);
254 gfc_conv_descriptor_stride (tree desc, tree dim)
259 tmp = gfc_conv_descriptor_dimension (desc, dim);
260 field = TYPE_FIELDS (TREE_TYPE (tmp));
261 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
262 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
264 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
265 tmp, field, NULL_TREE);
270 gfc_conv_descriptor_lbound (tree desc, tree dim)
275 tmp = gfc_conv_descriptor_dimension (desc, dim);
276 field = TYPE_FIELDS (TREE_TYPE (tmp));
277 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
278 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
280 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
281 tmp, field, NULL_TREE);
286 gfc_conv_descriptor_ubound (tree desc, tree dim)
291 tmp = gfc_conv_descriptor_dimension (desc, dim);
292 field = TYPE_FIELDS (TREE_TYPE (tmp));
293 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
294 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
296 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
297 tmp, field, NULL_TREE);
302 /* Build a null array descriptor constructor. */
305 gfc_build_null_descriptor (tree type)
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 gcc_assert (DATA_FIELD == 0);
312 field = TYPE_FIELDS (type);
314 /* Set a NULL data pointer. */
315 tmp = build_constructor_single (type, field, null_pointer_node);
316 TREE_CONSTANT (tmp) = 1;
317 /* All other fields are ignored. */
323 /* Cleanup those #defines. */
328 #undef DIMENSION_FIELD
329 #undef STRIDE_SUBFIELD
330 #undef LBOUND_SUBFIELD
331 #undef UBOUND_SUBFIELD
334 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
335 flags & 1 = Main loop body.
336 flags & 2 = temp copy loop. */
339 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
341 for (; ss != gfc_ss_terminator; ss = ss->next)
342 ss->useflags = flags;
345 static void gfc_free_ss (gfc_ss *);
348 /* Free a gfc_ss chain. */
351 gfc_free_ss_chain (gfc_ss * ss)
355 while (ss != gfc_ss_terminator)
357 gcc_assert (ss != NULL);
368 gfc_free_ss (gfc_ss * ss)
375 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
377 if (ss->data.info.subscript[n])
378 gfc_free_ss_chain (ss->data.info.subscript[n]);
390 /* Free all the SS associated with a loop. */
393 gfc_cleanup_loop (gfc_loopinfo * loop)
399 while (ss != gfc_ss_terminator)
401 gcc_assert (ss != NULL);
402 next = ss->loop_chain;
409 /* Associate a SS chain with a loop. */
412 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
416 if (head == gfc_ss_terminator)
420 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
422 if (ss->next == gfc_ss_terminator)
423 ss->loop_chain = loop->ss;
425 ss->loop_chain = ss->next;
427 gcc_assert (ss == gfc_ss_terminator);
432 /* Generate an initializer for a static pointer or allocatable array. */
435 gfc_trans_static_array_pointer (gfc_symbol * sym)
439 gcc_assert (TREE_STATIC (sym->backend_decl));
440 /* Just zero the data member. */
441 type = TREE_TYPE (sym->backend_decl);
442 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
446 /* If the bounds of SE's loop have not yet been set, see if they can be
447 determined from array spec AS, which is the array spec of a called
448 function. MAPPING maps the callee's dummy arguments to the values
449 that the caller is passing. Add any initialization and finalization
453 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
454 gfc_se * se, gfc_array_spec * as)
462 if (as && as->type == AS_EXPLICIT)
463 for (dim = 0; dim < se->loop->dimen; dim++)
465 n = se->loop->order[dim];
466 if (se->loop->to[n] == NULL_TREE)
468 /* Evaluate the lower bound. */
469 gfc_init_se (&tmpse, NULL);
470 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
471 gfc_add_block_to_block (&se->pre, &tmpse.pre);
472 gfc_add_block_to_block (&se->post, &tmpse.post);
473 lower = fold_convert (gfc_array_index_type, tmpse.expr);
475 /* ...and the upper bound. */
476 gfc_init_se (&tmpse, NULL);
477 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
478 gfc_add_block_to_block (&se->pre, &tmpse.pre);
479 gfc_add_block_to_block (&se->post, &tmpse.post);
480 upper = fold_convert (gfc_array_index_type, tmpse.expr);
482 /* Set the upper bound of the loop to UPPER - LOWER. */
483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
484 tmp = gfc_evaluate_now (tmp, &se->pre);
485 se->loop->to[n] = tmp;
491 /* Generate code to allocate an array temporary, or create a variable to
492 hold the data. If size is NULL, zero the descriptor so that the
493 callee will allocate the array. If DEALLOC is true, also generate code to
494 free the array afterwards.
496 If INITIAL is not NULL, it is packed using internal_pack and the result used
497 as data instead of allocating a fresh, unitialized area of memory.
499 Initialization code is added to PRE and finalization code to POST.
500 DYNAMIC is true if the caller may want to extend the array later
501 using realloc. This prevents us from putting the array on the stack. */
504 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
505 gfc_ss_info * info, tree size, tree nelem,
506 tree initial, bool dynamic, bool dealloc)
512 desc = info->descriptor;
513 info->offset = gfc_index_zero_node;
514 if (size == NULL_TREE || integer_zerop (size))
516 /* A callee allocated array. */
517 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
522 /* Allocate the temporary. */
523 onstack = !dynamic && initial == NULL_TREE
524 && gfc_can_put_var_on_stack (size);
528 /* Make a temporary variable to hold the data. */
529 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
531 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
533 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
535 tmp = gfc_create_var (tmp, "A");
536 tmp = build_fold_addr_expr (tmp);
537 gfc_conv_descriptor_data_set (pre, desc, tmp);
541 /* Allocate memory to hold the data or call internal_pack. */
542 if (initial == NULL_TREE)
544 tmp = gfc_call_malloc (pre, NULL, size);
545 tmp = gfc_evaluate_now (tmp, pre);
552 stmtblock_t do_copying;
554 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
555 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
556 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
557 tmp = gfc_get_element_type (tmp);
558 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
559 packed = gfc_create_var (build_pointer_type (tmp), "data");
561 tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial);
562 tmp = fold_convert (TREE_TYPE (packed), tmp);
563 gfc_add_modify (pre, packed, tmp);
565 tmp = build_fold_indirect_ref (initial);
566 source_data = gfc_conv_descriptor_data_get (tmp);
568 /* internal_pack may return source->data without any allocation
569 or copying if it is already packed. If that's the case, we
570 need to allocate and copy manually. */
572 gfc_start_block (&do_copying);
573 tmp = gfc_call_malloc (&do_copying, NULL, size);
574 tmp = fold_convert (TREE_TYPE (packed), tmp);
575 gfc_add_modify (&do_copying, packed, tmp);
576 tmp = gfc_build_memcpy_call (packed, source_data, size);
577 gfc_add_expr_to_block (&do_copying, tmp);
579 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
580 packed, source_data);
581 tmp = gfc_finish_block (&do_copying);
582 tmp = build3_v (COND_EXPR, was_packed, tmp, build_empty_stmt ());
583 gfc_add_expr_to_block (pre, tmp);
585 tmp = fold_convert (pvoid_type_node, packed);
588 gfc_conv_descriptor_data_set (pre, desc, tmp);
591 info->data = gfc_conv_descriptor_data_get (desc);
593 /* The offset is zero because we create temporaries with a zero
595 tmp = gfc_conv_descriptor_offset (desc);
596 gfc_add_modify (pre, tmp, gfc_index_zero_node);
598 if (dealloc && !onstack)
600 /* Free the temporary. */
601 tmp = gfc_conv_descriptor_data_get (desc);
602 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
603 gfc_add_expr_to_block (post, tmp);
608 /* Generate code to create and initialize the descriptor for a temporary
609 array. This is used for both temporaries needed by the scalarizer, and
610 functions returning arrays. Adjusts the loop variables to be
611 zero-based, and calculates the loop bounds for callee allocated arrays.
612 Allocate the array unless it's callee allocated (we have a callee
613 allocated array if 'callee_alloc' is true, or if loop->to[n] is
614 NULL_TREE for any n). Also fills in the descriptor, data and offset
615 fields of info if known. Returns the size of the array, or NULL for a
616 callee allocated array.
618 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
619 gfc_trans_allocate_array_storage.
623 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
624 gfc_loopinfo * loop, gfc_ss_info * info,
625 tree eltype, tree initial, bool dynamic,
626 bool dealloc, bool callee_alloc, locus * where)
638 gcc_assert (info->dimen > 0);
640 if (gfc_option.warn_array_temp && where)
641 gfc_warning ("Creating array temporary at %L", where);
643 /* Set the lower bound to zero. */
644 for (dim = 0; dim < info->dimen; dim++)
646 n = loop->order[dim];
647 /* Callee allocated arrays may not have a known bound yet. */
649 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
650 gfc_array_index_type,
651 loop->to[n], loop->from[n]), pre);
652 loop->from[n] = gfc_index_zero_node;
654 info->delta[dim] = gfc_index_zero_node;
655 info->start[dim] = gfc_index_zero_node;
656 info->end[dim] = gfc_index_zero_node;
657 info->stride[dim] = gfc_index_one_node;
658 info->dim[dim] = dim;
661 /* Initialize the descriptor. */
663 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
665 desc = gfc_create_var (type, "atmp");
666 GFC_DECL_PACKED_ARRAY (desc) = 1;
668 info->descriptor = desc;
669 size = gfc_index_one_node;
671 /* Fill in the array dtype. */
672 tmp = gfc_conv_descriptor_dtype (desc);
673 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
676 Fill in the bounds and stride. This is a packed array, so:
679 for (n = 0; n < rank; n++)
682 delta = ubound[n] + 1 - lbound[n];
685 size = size * sizeof(element);
690 /* If there is at least one null loop->to[n], it is a callee allocated
692 for (n = 0; n < info->dimen; n++)
693 if (loop->to[n] == NULL_TREE)
699 for (n = 0; n < info->dimen; n++)
701 if (size == NULL_TREE)
703 /* For a callee allocated array express the loop bounds in terms
704 of the descriptor fields. */
706 fold_build2 (MINUS_EXPR, gfc_array_index_type,
707 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
708 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
713 /* Store the stride and bound components in the descriptor. */
714 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
715 gfc_add_modify (pre, tmp, size);
717 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
718 gfc_add_modify (pre, tmp, gfc_index_zero_node);
720 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
721 gfc_add_modify (pre, tmp, loop->to[n]);
723 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
724 loop->to[n], gfc_index_one_node);
726 /* Check whether the size for this dimension is negative. */
727 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
728 gfc_index_zero_node);
729 cond = gfc_evaluate_now (cond, pre);
734 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
736 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
737 size = gfc_evaluate_now (size, pre);
740 /* Get the size of the array. */
742 if (size && !callee_alloc)
744 /* If or_expr is true, then the extent in at least one
745 dimension is zero and the size is set to zero. */
746 size = fold_build3 (COND_EXPR, gfc_array_index_type,
747 or_expr, gfc_index_zero_node, size);
750 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
751 fold_convert (gfc_array_index_type,
752 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
760 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
763 if (info->dimen > loop->temp_dim)
764 loop->temp_dim = info->dimen;
770 /* Generate code to transpose array EXPR by creating a new descriptor
771 in which the dimension specifications have been reversed. */
774 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
776 tree dest, src, dest_index, src_index;
778 gfc_ss_info *dest_info, *src_info;
779 gfc_ss *dest_ss, *src_ss;
785 src_ss = gfc_walk_expr (expr);
788 src_info = &src_ss->data.info;
789 dest_info = &dest_ss->data.info;
790 gcc_assert (dest_info->dimen == 2);
791 gcc_assert (src_info->dimen == 2);
793 /* Get a descriptor for EXPR. */
794 gfc_init_se (&src_se, NULL);
795 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
796 gfc_add_block_to_block (&se->pre, &src_se.pre);
797 gfc_add_block_to_block (&se->post, &src_se.post);
800 /* Allocate a new descriptor for the return value. */
801 dest = gfc_create_var (TREE_TYPE (src), "atmp");
802 dest_info->descriptor = dest;
805 /* Copy across the dtype field. */
806 gfc_add_modify (&se->pre,
807 gfc_conv_descriptor_dtype (dest),
808 gfc_conv_descriptor_dtype (src));
810 /* Copy the dimension information, renumbering dimension 1 to 0 and
812 for (n = 0; n < 2; n++)
814 dest_info->delta[n] = gfc_index_zero_node;
815 dest_info->start[n] = gfc_index_zero_node;
816 dest_info->end[n] = gfc_index_zero_node;
817 dest_info->stride[n] = gfc_index_one_node;
818 dest_info->dim[n] = n;
820 dest_index = gfc_rank_cst[n];
821 src_index = gfc_rank_cst[1 - n];
823 gfc_add_modify (&se->pre,
824 gfc_conv_descriptor_stride (dest, dest_index),
825 gfc_conv_descriptor_stride (src, src_index));
827 gfc_add_modify (&se->pre,
828 gfc_conv_descriptor_lbound (dest, dest_index),
829 gfc_conv_descriptor_lbound (src, src_index));
831 gfc_add_modify (&se->pre,
832 gfc_conv_descriptor_ubound (dest, dest_index),
833 gfc_conv_descriptor_ubound (src, src_index));
837 gcc_assert (integer_zerop (loop->from[n]));
839 fold_build2 (MINUS_EXPR, gfc_array_index_type,
840 gfc_conv_descriptor_ubound (dest, dest_index),
841 gfc_conv_descriptor_lbound (dest, dest_index));
845 /* Copy the data pointer. */
846 dest_info->data = gfc_conv_descriptor_data_get (src);
847 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
849 /* Copy the offset. This is not changed by transposition; the top-left
850 element is still at the same offset as before, except where the loop
852 if (!integer_zerop (loop->from[0]))
853 dest_info->offset = gfc_conv_descriptor_offset (src);
855 dest_info->offset = gfc_index_zero_node;
857 gfc_add_modify (&se->pre,
858 gfc_conv_descriptor_offset (dest),
861 if (dest_info->dimen > loop->temp_dim)
862 loop->temp_dim = dest_info->dimen;
866 /* Return the number of iterations in a loop that starts at START,
867 ends at END, and has step STEP. */
870 gfc_get_iteration_count (tree start, tree end, tree step)
875 type = TREE_TYPE (step);
876 tmp = fold_build2 (MINUS_EXPR, type, end, start);
877 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
878 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
879 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
880 return fold_convert (gfc_array_index_type, tmp);
884 /* Extend the data in array DESC by EXTRA elements. */
887 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
894 if (integer_zerop (extra))
897 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
899 /* Add EXTRA to the upper bound. */
900 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
901 gfc_add_modify (pblock, ubound, tmp);
903 /* Get the value of the current data pointer. */
904 arg0 = gfc_conv_descriptor_data_get (desc);
906 /* Calculate the new array size. */
907 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
908 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
909 ubound, gfc_index_one_node);
910 arg1 = fold_build2 (MULT_EXPR, size_type_node,
911 fold_convert (size_type_node, tmp),
912 fold_convert (size_type_node, size));
914 /* Call the realloc() function. */
915 tmp = gfc_call_realloc (pblock, arg0, arg1);
916 gfc_conv_descriptor_data_set (pblock, desc, tmp);
920 /* Return true if the bounds of iterator I can only be determined
924 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
926 return (i->start->expr_type != EXPR_CONSTANT
927 || i->end->expr_type != EXPR_CONSTANT
928 || i->step->expr_type != EXPR_CONSTANT);
932 /* Split the size of constructor element EXPR into the sum of two terms,
933 one of which can be determined at compile time and one of which must
934 be calculated at run time. Set *SIZE to the former and return true
935 if the latter might be nonzero. */
938 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
940 if (expr->expr_type == EXPR_ARRAY)
941 return gfc_get_array_constructor_size (size, expr->value.constructor);
942 else if (expr->rank > 0)
944 /* Calculate everything at run time. */
945 mpz_set_ui (*size, 0);
950 /* A single element. */
951 mpz_set_ui (*size, 1);
957 /* Like gfc_get_array_constructor_element_size, but applied to the whole
958 of array constructor C. */
961 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
968 mpz_set_ui (*size, 0);
973 for (; c; c = c->next)
976 if (i && gfc_iterator_has_dynamic_bounds (i))
980 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
983 /* Multiply the static part of the element size by the
984 number of iterations. */
985 mpz_sub (val, i->end->value.integer, i->start->value.integer);
986 mpz_fdiv_q (val, val, i->step->value.integer);
987 mpz_add_ui (val, val, 1);
988 if (mpz_sgn (val) > 0)
989 mpz_mul (len, len, val);
993 mpz_add (*size, *size, len);
1002 /* Make sure offset is a variable. */
1005 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1008 /* We should have already created the offset variable. We cannot
1009 create it here because we may be in an inner scope. */
1010 gcc_assert (*offsetvar != NULL_TREE);
1011 gfc_add_modify (pblock, *offsetvar, *poffset);
1012 *poffset = *offsetvar;
1013 TREE_USED (*offsetvar) = 1;
1017 /* Variables needed for bounds-checking. */
1018 static bool first_len;
1019 static tree first_len_val;
1020 static bool typespec_chararray_ctor;
1023 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1024 tree offset, gfc_se * se, gfc_expr * expr)
1028 gfc_conv_expr (se, expr);
1030 /* Store the value. */
1031 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
1032 tmp = gfc_build_array_ref (tmp, offset, NULL);
1034 if (expr->ts.type == BT_CHARACTER)
1036 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1039 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1040 esize = fold_convert (gfc_charlen_type_node, esize);
1041 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1042 build_int_cst (gfc_charlen_type_node,
1043 gfc_character_kinds[i].bit_size / 8));
1045 gfc_conv_string_parameter (se);
1046 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1048 /* The temporary is an array of pointers. */
1049 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1050 gfc_add_modify (&se->pre, tmp, se->expr);
1054 /* The temporary is an array of string values. */
1055 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1056 /* We know the temporary and the value will be the same length,
1057 so can use memcpy. */
1058 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1059 se->string_length, se->expr, expr->ts.kind);
1061 if (flag_bounds_check && !typespec_chararray_ctor)
1065 gfc_add_modify (&se->pre, first_len_val,
1071 /* Verify that all constructor elements are of the same
1073 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1074 first_len_val, se->string_length);
1075 gfc_trans_runtime_check
1076 (true, false, cond, &se->pre, &expr->where,
1077 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1078 fold_convert (long_integer_type_node, first_len_val),
1079 fold_convert (long_integer_type_node, se->string_length));
1085 /* TODO: Should the frontend already have done this conversion? */
1086 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1087 gfc_add_modify (&se->pre, tmp, se->expr);
1090 gfc_add_block_to_block (pblock, &se->pre);
1091 gfc_add_block_to_block (pblock, &se->post);
1095 /* Add the contents of an array to the constructor. DYNAMIC is as for
1096 gfc_trans_array_constructor_value. */
1099 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1100 tree type ATTRIBUTE_UNUSED,
1101 tree desc, gfc_expr * expr,
1102 tree * poffset, tree * offsetvar,
1113 /* We need this to be a variable so we can increment it. */
1114 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1116 gfc_init_se (&se, NULL);
1118 /* Walk the array expression. */
1119 ss = gfc_walk_expr (expr);
1120 gcc_assert (ss != gfc_ss_terminator);
1122 /* Initialize the scalarizer. */
1123 gfc_init_loopinfo (&loop);
1124 gfc_add_ss_to_loop (&loop, ss);
1126 /* Initialize the loop. */
1127 gfc_conv_ss_startstride (&loop);
1128 gfc_conv_loop_setup (&loop, &expr->where);
1130 /* Make sure the constructed array has room for the new data. */
1133 /* Set SIZE to the total number of elements in the subarray. */
1134 size = gfc_index_one_node;
1135 for (n = 0; n < loop.dimen; n++)
1137 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1138 gfc_index_one_node);
1139 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1142 /* Grow the constructed array by SIZE elements. */
1143 gfc_grow_array (&loop.pre, desc, size);
1146 /* Make the loop body. */
1147 gfc_mark_ss_chain_used (ss, 1);
1148 gfc_start_scalarized_body (&loop, &body);
1149 gfc_copy_loopinfo_to_se (&se, &loop);
1152 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1153 gcc_assert (se.ss == gfc_ss_terminator);
1155 /* Increment the offset. */
1156 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1157 *poffset, gfc_index_one_node);
1158 gfc_add_modify (&body, *poffset, tmp);
1160 /* Finish the loop. */
1161 gfc_trans_scalarizing_loops (&loop, &body);
1162 gfc_add_block_to_block (&loop.pre, &loop.post);
1163 tmp = gfc_finish_block (&loop.pre);
1164 gfc_add_expr_to_block (pblock, tmp);
1166 gfc_cleanup_loop (&loop);
1170 /* Assign the values to the elements of an array constructor. DYNAMIC
1171 is true if descriptor DESC only contains enough data for the static
1172 size calculated by gfc_get_array_constructor_size. When true, memory
1173 for the dynamic parts must be allocated using realloc. */
1176 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1177 tree desc, gfc_constructor * c,
1178 tree * poffset, tree * offsetvar,
1187 for (; c; c = c->next)
1189 /* If this is an iterator or an array, the offset must be a variable. */
1190 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1191 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1193 gfc_start_block (&body);
1195 if (c->expr->expr_type == EXPR_ARRAY)
1197 /* Array constructors can be nested. */
1198 gfc_trans_array_constructor_value (&body, type, desc,
1199 c->expr->value.constructor,
1200 poffset, offsetvar, dynamic);
1202 else if (c->expr->rank > 0)
1204 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1205 poffset, offsetvar, dynamic);
1209 /* This code really upsets the gimplifier so don't bother for now. */
1216 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1223 /* Scalar values. */
1224 gfc_init_se (&se, NULL);
1225 gfc_trans_array_ctor_element (&body, desc, *poffset,
1228 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1229 *poffset, gfc_index_one_node);
1233 /* Collect multiple scalar constants into a constructor. */
1241 /* Count the number of consecutive scalar constants. */
1242 while (p && !(p->iterator
1243 || p->expr->expr_type != EXPR_CONSTANT))
1245 gfc_init_se (&se, NULL);
1246 gfc_conv_constant (&se, p->expr);
1248 /* For constant character array constructors we build
1249 an array of pointers. */
1250 if (p->expr->ts.type == BT_CHARACTER
1251 && POINTER_TYPE_P (type))
1252 se.expr = gfc_build_addr_expr
1253 (gfc_get_pchar_type (p->expr->ts.kind),
1256 list = tree_cons (NULL_TREE, se.expr, list);
1261 bound = build_int_cst (NULL_TREE, n - 1);
1262 /* Create an array type to hold them. */
1263 tmptype = build_range_type (gfc_array_index_type,
1264 gfc_index_zero_node, bound);
1265 tmptype = build_array_type (type, tmptype);
1267 init = build_constructor_from_list (tmptype, nreverse (list));
1268 TREE_CONSTANT (init) = 1;
1269 TREE_STATIC (init) = 1;
1270 /* Create a static variable to hold the data. */
1271 tmp = gfc_create_var (tmptype, "data");
1272 TREE_STATIC (tmp) = 1;
1273 TREE_CONSTANT (tmp) = 1;
1274 TREE_READONLY (tmp) = 1;
1275 DECL_INITIAL (tmp) = init;
1278 /* Use BUILTIN_MEMCPY to assign the values. */
1279 tmp = gfc_conv_descriptor_data_get (desc);
1280 tmp = build_fold_indirect_ref (tmp);
1281 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1282 tmp = build_fold_addr_expr (tmp);
1283 init = build_fold_addr_expr (init);
1285 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1286 bound = build_int_cst (NULL_TREE, n * size);
1287 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
1289 gfc_add_expr_to_block (&body, tmp);
1291 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1293 build_int_cst (gfc_array_index_type, n));
1295 if (!INTEGER_CST_P (*poffset))
1297 gfc_add_modify (&body, *offsetvar, *poffset);
1298 *poffset = *offsetvar;
1302 /* The frontend should already have done any expansions
1306 /* Pass the code as is. */
1307 tmp = gfc_finish_block (&body);
1308 gfc_add_expr_to_block (pblock, tmp);
1312 /* Build the implied do-loop. */
1322 loopbody = gfc_finish_block (&body);
1324 if (c->iterator->var->symtree->n.sym->backend_decl)
1326 gfc_init_se (&se, NULL);
1327 gfc_conv_expr (&se, c->iterator->var);
1328 gfc_add_block_to_block (pblock, &se.pre);
1333 /* If the iterator appears in a specification expression in
1334 an interface mapping, we need to make a temp for the loop
1335 variable because it is not declared locally. */
1336 loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
1337 loopvar = gfc_create_var (loopvar, "loopvar");
1340 /* Make a temporary, store the current value in that
1341 and return it, once the loop is done. */
1342 tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
1343 gfc_add_modify (pblock, tmp_loopvar, loopvar);
1345 /* Initialize the loop. */
1346 gfc_init_se (&se, NULL);
1347 gfc_conv_expr_val (&se, c->iterator->start);
1348 gfc_add_block_to_block (pblock, &se.pre);
1349 gfc_add_modify (pblock, loopvar, se.expr);
1351 gfc_init_se (&se, NULL);
1352 gfc_conv_expr_val (&se, c->iterator->end);
1353 gfc_add_block_to_block (pblock, &se.pre);
1354 end = gfc_evaluate_now (se.expr, pblock);
1356 gfc_init_se (&se, NULL);
1357 gfc_conv_expr_val (&se, c->iterator->step);
1358 gfc_add_block_to_block (pblock, &se.pre);
1359 step = gfc_evaluate_now (se.expr, pblock);
1361 /* If this array expands dynamically, and the number of iterations
1362 is not constant, we won't have allocated space for the static
1363 part of C->EXPR's size. Do that now. */
1364 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1366 /* Get the number of iterations. */
1367 tmp = gfc_get_iteration_count (loopvar, end, step);
1369 /* Get the static part of C->EXPR's size. */
1370 gfc_get_array_constructor_element_size (&size, c->expr);
1371 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1373 /* Grow the array by TMP * TMP2 elements. */
1374 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1375 gfc_grow_array (pblock, desc, tmp);
1378 /* Generate the loop body. */
1379 exit_label = gfc_build_label_decl (NULL_TREE);
1380 gfc_start_block (&body);
1382 /* Generate the exit condition. Depending on the sign of
1383 the step variable we have to generate the correct
1385 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1386 build_int_cst (TREE_TYPE (step), 0));
1387 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1388 fold_build2 (GT_EXPR, boolean_type_node,
1390 fold_build2 (LT_EXPR, boolean_type_node,
1392 tmp = build1_v (GOTO_EXPR, exit_label);
1393 TREE_USED (exit_label) = 1;
1394 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1395 gfc_add_expr_to_block (&body, tmp);
1397 /* The main loop body. */
1398 gfc_add_expr_to_block (&body, loopbody);
1400 /* Increase loop variable by step. */
1401 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1402 gfc_add_modify (&body, loopvar, tmp);
1404 /* Finish the loop. */
1405 tmp = gfc_finish_block (&body);
1406 tmp = build1_v (LOOP_EXPR, tmp);
1407 gfc_add_expr_to_block (pblock, tmp);
1409 /* Add the exit label. */
1410 tmp = build1_v (LABEL_EXPR, exit_label);
1411 gfc_add_expr_to_block (pblock, tmp);
1413 /* Restore the original value of the loop counter. */
1414 gfc_add_modify (pblock, loopvar, tmp_loopvar);
1421 /* Figure out the string length of a variable reference expression.
1422 Used by get_array_ctor_strlen. */
1425 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1431 /* Don't bother if we already know the length is a constant. */
1432 if (*len && INTEGER_CST_P (*len))
1435 ts = &expr->symtree->n.sym->ts;
1436 for (ref = expr->ref; ref; ref = ref->next)
1441 /* Array references don't change the string length. */
1445 /* Use the length of the component. */
1446 ts = &ref->u.c.component->ts;
1450 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1451 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1453 mpz_init_set_ui (char_len, 1);
1454 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1455 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1456 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1457 *len = convert (gfc_charlen_type_node, *len);
1458 mpz_clear (char_len);
1462 /* TODO: Substrings are tricky because we can't evaluate the
1463 expression more than once. For now we just give up, and hope
1464 we can figure it out elsewhere. */
1469 *len = ts->cl->backend_decl;
1473 /* A catch-all to obtain the string length for anything that is not a
1474 constant, array or variable. */
1476 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1481 /* Don't bother if we already know the length is a constant. */
1482 if (*len && INTEGER_CST_P (*len))
1485 if (!e->ref && e->ts.cl && e->ts.cl->length
1486 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1489 gfc_conv_const_charlen (e->ts.cl);
1490 *len = e->ts.cl->backend_decl;
1494 /* Otherwise, be brutal even if inefficient. */
1495 ss = gfc_walk_expr (e);
1496 gfc_init_se (&se, NULL);
1498 /* No function call, in case of side effects. */
1499 se.no_function_call = 1;
1500 if (ss == gfc_ss_terminator)
1501 gfc_conv_expr (&se, e);
1503 gfc_conv_expr_descriptor (&se, e, ss);
1505 /* Fix the value. */
1506 *len = gfc_evaluate_now (se.string_length, &se.pre);
1508 gfc_add_block_to_block (block, &se.pre);
1509 gfc_add_block_to_block (block, &se.post);
1511 e->ts.cl->backend_decl = *len;
1516 /* Figure out the string length of a character array constructor.
1517 If len is NULL, don't calculate the length; this happens for recursive calls
1518 when a sub-array-constructor is an element but not at the first position,
1519 so when we're not interested in the length.
1520 Returns TRUE if all elements are character constants. */
1523 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1532 *len = build_int_cstu (gfc_charlen_type_node, 0);
1536 /* Loop over all constructor elements to find out is_const, but in len we
1537 want to store the length of the first, not the last, element. We can
1538 of course exit the loop as soon as is_const is found to be false. */
1539 for (; c && is_const; c = c->next)
1541 switch (c->expr->expr_type)
1544 if (len && !(*len && INTEGER_CST_P (*len)))
1545 *len = build_int_cstu (gfc_charlen_type_node,
1546 c->expr->value.character.length);
1550 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1557 get_array_ctor_var_strlen (c->expr, len);
1563 get_array_ctor_all_strlen (block, c->expr, len);
1567 /* After the first iteration, we don't want the length modified. */
1574 /* Check whether the array constructor C consists entirely of constant
1575 elements, and if so returns the number of those elements, otherwise
1576 return zero. Note, an empty or NULL array constructor returns zero. */
1578 unsigned HOST_WIDE_INT
1579 gfc_constant_array_constructor_p (gfc_constructor * c)
1581 unsigned HOST_WIDE_INT nelem = 0;
1586 || c->expr->rank > 0
1587 || c->expr->expr_type != EXPR_CONSTANT)
1596 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1597 and the tree type of it's elements, TYPE, return a static constant
1598 variable that is compile-time initialized. */
1601 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1603 tree tmptype, list, init, tmp;
1604 HOST_WIDE_INT nelem;
1610 /* First traverse the constructor list, converting the constants
1611 to tree to build an initializer. */
1614 c = expr->value.constructor;
1617 gfc_init_se (&se, NULL);
1618 gfc_conv_constant (&se, c->expr);
1619 if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
1620 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1622 list = tree_cons (NULL_TREE, se.expr, list);
1627 /* Next determine the tree type for the array. We use the gfortran
1628 front-end's gfc_get_nodesc_array_type in order to create a suitable
1629 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1631 memset (&as, 0, sizeof (gfc_array_spec));
1633 as.rank = expr->rank;
1634 as.type = AS_EXPLICIT;
1637 as.lower[0] = gfc_int_expr (0);
1638 as.upper[0] = gfc_int_expr (nelem - 1);
1641 for (i = 0; i < expr->rank; i++)
1643 int tmp = (int) mpz_get_si (expr->shape[i]);
1644 as.lower[i] = gfc_int_expr (0);
1645 as.upper[i] = gfc_int_expr (tmp - 1);
1648 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
1650 init = build_constructor_from_list (tmptype, nreverse (list));
1652 TREE_CONSTANT (init) = 1;
1653 TREE_STATIC (init) = 1;
1655 tmp = gfc_create_var (tmptype, "A");
1656 TREE_STATIC (tmp) = 1;
1657 TREE_CONSTANT (tmp) = 1;
1658 TREE_READONLY (tmp) = 1;
1659 DECL_INITIAL (tmp) = init;
1665 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1666 This mostly initializes the scalarizer state info structure with the
1667 appropriate values to directly use the array created by the function
1668 gfc_build_constant_array_constructor. */
1671 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1672 gfc_ss * ss, tree type)
1678 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1680 info = &ss->data.info;
1682 info->descriptor = tmp;
1683 info->data = build_fold_addr_expr (tmp);
1684 info->offset = gfc_index_zero_node;
1686 for (i = 0; i < info->dimen; i++)
1688 info->delta[i] = gfc_index_zero_node;
1689 info->start[i] = gfc_index_zero_node;
1690 info->end[i] = gfc_index_zero_node;
1691 info->stride[i] = gfc_index_one_node;
1695 if (info->dimen > loop->temp_dim)
1696 loop->temp_dim = info->dimen;
1699 /* Helper routine of gfc_trans_array_constructor to determine if the
1700 bounds of the loop specified by LOOP are constant and simple enough
1701 to use with gfc_trans_constant_array_constructor. Returns the
1702 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1705 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1707 tree size = gfc_index_one_node;
1711 for (i = 0; i < loop->dimen; i++)
1713 /* If the bounds aren't constant, return NULL_TREE. */
1714 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1716 if (!integer_zerop (loop->from[i]))
1718 /* Only allow nonzero "from" in one-dimensional arrays. */
1719 if (loop->dimen != 1)
1721 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1722 loop->to[i], loop->from[i]);
1726 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1727 tmp, gfc_index_one_node);
1728 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1735 /* Array constructors are handled by constructing a temporary, then using that
1736 within the scalarization loop. This is not optimal, but seems by far the
1740 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1748 bool old_first_len, old_typespec_chararray_ctor;
1749 tree old_first_len_val;
1751 /* Save the old values for nested checking. */
1752 old_first_len = first_len;
1753 old_first_len_val = first_len_val;
1754 old_typespec_chararray_ctor = typespec_chararray_ctor;
1756 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1757 typespec was given for the array constructor. */
1758 typespec_chararray_ctor = (ss->expr->ts.cl
1759 && ss->expr->ts.cl->length_from_typespec);
1761 if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
1762 && !typespec_chararray_ctor)
1764 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1768 ss->data.info.dimen = loop->dimen;
1770 c = ss->expr->value.constructor;
1771 if (ss->expr->ts.type == BT_CHARACTER)
1775 /* get_array_ctor_strlen walks the elements of the constructor, if a
1776 typespec was given, we already know the string length and want the one
1778 if (typespec_chararray_ctor && ss->expr->ts.cl->length
1779 && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
1783 const_string = false;
1784 gfc_init_se (&length_se, NULL);
1785 gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
1786 gfc_charlen_type_node);
1787 ss->string_length = length_se.expr;
1788 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1789 gfc_add_block_to_block (&loop->post, &length_se.post);
1792 const_string = get_array_ctor_strlen (&loop->pre, c,
1793 &ss->string_length);
1795 /* Complex character array constructors should have been taken care of
1796 and not end up here. */
1797 gcc_assert (ss->string_length);
1799 ss->expr->ts.cl->backend_decl = ss->string_length;
1801 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1803 type = build_pointer_type (type);
1806 type = gfc_typenode_for_spec (&ss->expr->ts);
1808 /* See if the constructor determines the loop bounds. */
1811 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1813 /* We have a multidimensional parameter. */
1815 for (n = 0; n < ss->expr->rank; n++)
1817 loop->from[n] = gfc_index_zero_node;
1818 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1819 gfc_index_integer_kind);
1820 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1821 loop->to[n], gfc_index_one_node);
1825 if (loop->to[0] == NULL_TREE)
1829 /* We should have a 1-dimensional, zero-based loop. */
1830 gcc_assert (loop->dimen == 1);
1831 gcc_assert (integer_zerop (loop->from[0]));
1833 /* Split the constructor size into a static part and a dynamic part.
1834 Allocate the static size up-front and record whether the dynamic
1835 size might be nonzero. */
1837 dynamic = gfc_get_array_constructor_size (&size, c);
1838 mpz_sub_ui (size, size, 1);
1839 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1843 /* Special case constant array constructors. */
1846 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1849 tree size = constant_array_constructor_loop_size (loop);
1850 if (size && compare_tree_int (size, nelem) == 0)
1852 gfc_trans_constant_array_constructor (loop, ss, type);
1858 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1859 type, NULL_TREE, dynamic, true, false, where);
1861 desc = ss->data.info.descriptor;
1862 offset = gfc_index_zero_node;
1863 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1864 TREE_NO_WARNING (offsetvar) = 1;
1865 TREE_USED (offsetvar) = 0;
1866 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1867 &offset, &offsetvar, dynamic);
1869 /* If the array grows dynamically, the upper bound of the loop variable
1870 is determined by the array's final upper bound. */
1872 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1874 if (TREE_USED (offsetvar))
1875 pushdecl (offsetvar);
1877 gcc_assert (INTEGER_CST_P (offset));
1879 /* Disable bound checking for now because it's probably broken. */
1880 if (flag_bounds_check)
1887 /* Restore old values of globals. */
1888 first_len = old_first_len;
1889 first_len_val = old_first_len_val;
1890 typespec_chararray_ctor = old_typespec_chararray_ctor;
1894 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1895 called after evaluating all of INFO's vector dimensions. Go through
1896 each such vector dimension and see if we can now fill in any missing
1900 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1909 for (n = 0; n < loop->dimen; n++)
1912 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1913 && loop->to[n] == NULL)
1915 /* Loop variable N indexes vector dimension DIM, and we don't
1916 yet know the upper bound of loop variable N. Set it to the
1917 difference between the vector's upper and lower bounds. */
1918 gcc_assert (loop->from[n] == gfc_index_zero_node);
1919 gcc_assert (info->subscript[dim]
1920 && info->subscript[dim]->type == GFC_SS_VECTOR);
1922 gfc_init_se (&se, NULL);
1923 desc = info->subscript[dim]->data.info.descriptor;
1924 zero = gfc_rank_cst[0];
1925 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1926 gfc_conv_descriptor_ubound (desc, zero),
1927 gfc_conv_descriptor_lbound (desc, zero));
1928 tmp = gfc_evaluate_now (tmp, &loop->pre);
1935 /* Add the pre and post chains for all the scalar expressions in a SS chain
1936 to loop. This is called after the loop parameters have been calculated,
1937 but before the actual scalarizing loops. */
1940 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
1946 /* TODO: This can generate bad code if there are ordering dependencies,
1947 e.g., a callee allocated function and an unknown size constructor. */
1948 gcc_assert (ss != NULL);
1950 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1957 /* Scalar expression. Evaluate this now. This includes elemental
1958 dimension indices, but not array section bounds. */
1959 gfc_init_se (&se, NULL);
1960 gfc_conv_expr (&se, ss->expr);
1961 gfc_add_block_to_block (&loop->pre, &se.pre);
1963 if (ss->expr->ts.type != BT_CHARACTER)
1965 /* Move the evaluation of scalar expressions outside the
1966 scalarization loop, except for WHERE assignments. */
1968 se.expr = convert(gfc_array_index_type, se.expr);
1970 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1971 gfc_add_block_to_block (&loop->pre, &se.post);
1974 gfc_add_block_to_block (&loop->post, &se.post);
1976 ss->data.scalar.expr = se.expr;
1977 ss->string_length = se.string_length;
1980 case GFC_SS_REFERENCE:
1981 /* Scalar reference. Evaluate this now. */
1982 gfc_init_se (&se, NULL);
1983 gfc_conv_expr_reference (&se, ss->expr);
1984 gfc_add_block_to_block (&loop->pre, &se.pre);
1985 gfc_add_block_to_block (&loop->post, &se.post);
1987 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1988 ss->string_length = se.string_length;
1991 case GFC_SS_SECTION:
1992 /* Add the expressions for scalar and vector subscripts. */
1993 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1994 if (ss->data.info.subscript[n])
1995 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
1998 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2002 /* Get the vector's descriptor and store it in SS. */
2003 gfc_init_se (&se, NULL);
2004 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2005 gfc_add_block_to_block (&loop->pre, &se.pre);
2006 gfc_add_block_to_block (&loop->post, &se.post);
2007 ss->data.info.descriptor = se.expr;
2010 case GFC_SS_INTRINSIC:
2011 gfc_add_intrinsic_ss_code (loop, ss);
2014 case GFC_SS_FUNCTION:
2015 /* Array function return value. We call the function and save its
2016 result in a temporary for use inside the loop. */
2017 gfc_init_se (&se, NULL);
2020 gfc_conv_expr (&se, ss->expr);
2021 gfc_add_block_to_block (&loop->pre, &se.pre);
2022 gfc_add_block_to_block (&loop->post, &se.post);
2023 ss->string_length = se.string_length;
2026 case GFC_SS_CONSTRUCTOR:
2027 if (ss->expr->ts.type == BT_CHARACTER
2028 && ss->string_length == NULL
2030 && ss->expr->ts.cl->length)
2032 gfc_init_se (&se, NULL);
2033 gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
2034 gfc_charlen_type_node);
2035 ss->string_length = se.expr;
2036 gfc_add_block_to_block (&loop->pre, &se.pre);
2037 gfc_add_block_to_block (&loop->post, &se.post);
2039 gfc_trans_array_constructor (loop, ss, where);
2043 case GFC_SS_COMPONENT:
2044 /* Do nothing. These are handled elsewhere. */
2054 /* Translate expressions for the descriptor and data pointer of a SS. */
2058 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2063 /* Get the descriptor for the array to be scalarized. */
2064 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2065 gfc_init_se (&se, NULL);
2066 se.descriptor_only = 1;
2067 gfc_conv_expr_lhs (&se, ss->expr);
2068 gfc_add_block_to_block (block, &se.pre);
2069 ss->data.info.descriptor = se.expr;
2070 ss->string_length = se.string_length;
2074 /* Also the data pointer. */
2075 tmp = gfc_conv_array_data (se.expr);
2076 /* If this is a variable or address of a variable we use it directly.
2077 Otherwise we must evaluate it now to avoid breaking dependency
2078 analysis by pulling the expressions for elemental array indices
2081 || (TREE_CODE (tmp) == ADDR_EXPR
2082 && DECL_P (TREE_OPERAND (tmp, 0)))))
2083 tmp = gfc_evaluate_now (tmp, block);
2084 ss->data.info.data = tmp;
2086 tmp = gfc_conv_array_offset (se.expr);
2087 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2092 /* Initialize a gfc_loopinfo structure. */
2095 gfc_init_loopinfo (gfc_loopinfo * loop)
2099 memset (loop, 0, sizeof (gfc_loopinfo));
2100 gfc_init_block (&loop->pre);
2101 gfc_init_block (&loop->post);
2103 /* Initially scalarize in order. */
2104 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2107 loop->ss = gfc_ss_terminator;
2111 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2115 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2121 /* Return an expression for the data pointer of an array. */
2124 gfc_conv_array_data (tree descriptor)
2128 type = TREE_TYPE (descriptor);
2129 if (GFC_ARRAY_TYPE_P (type))
2131 if (TREE_CODE (type) == POINTER_TYPE)
2135 /* Descriptorless arrays. */
2136 return build_fold_addr_expr (descriptor);
2140 return gfc_conv_descriptor_data_get (descriptor);
2144 /* Return an expression for the base offset of an array. */
2147 gfc_conv_array_offset (tree descriptor)
2151 type = TREE_TYPE (descriptor);
2152 if (GFC_ARRAY_TYPE_P (type))
2153 return GFC_TYPE_ARRAY_OFFSET (type);
2155 return gfc_conv_descriptor_offset (descriptor);
2159 /* Get an expression for the array stride. */
2162 gfc_conv_array_stride (tree descriptor, int dim)
2167 type = TREE_TYPE (descriptor);
2169 /* For descriptorless arrays use the array size. */
2170 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2171 if (tmp != NULL_TREE)
2174 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
2179 /* Like gfc_conv_array_stride, but for the lower bound. */
2182 gfc_conv_array_lbound (tree descriptor, int dim)
2187 type = TREE_TYPE (descriptor);
2189 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2190 if (tmp != NULL_TREE)
2193 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
2198 /* Like gfc_conv_array_stride, but for the upper bound. */
2201 gfc_conv_array_ubound (tree descriptor, int dim)
2206 type = TREE_TYPE (descriptor);
2208 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2209 if (tmp != NULL_TREE)
2212 /* This should only ever happen when passing an assumed shape array
2213 as an actual parameter. The value will never be used. */
2214 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2215 return gfc_index_zero_node;
2217 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
2222 /* Generate code to perform an array index bound check. */
2225 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2226 locus * where, bool check_upper)
2231 const char * name = NULL;
2233 if (!flag_bounds_check)
2236 index = gfc_evaluate_now (index, &se->pre);
2238 /* We find a name for the error message. */
2240 name = se->ss->expr->symtree->name;
2242 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2243 && se->loop->ss->expr->symtree)
2244 name = se->loop->ss->expr->symtree->name;
2246 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2247 && se->loop->ss->loop_chain->expr
2248 && se->loop->ss->loop_chain->expr->symtree)
2249 name = se->loop->ss->loop_chain->expr->symtree->name;
2251 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2252 && se->loop->ss->loop_chain->expr->symtree)
2253 name = se->loop->ss->loop_chain->expr->symtree->name;
2255 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2257 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2258 && se->loop->ss->expr->value.function.name)
2259 name = se->loop->ss->expr->value.function.name;
2261 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2262 || se->loop->ss->type == GFC_SS_SCALAR)
2263 name = "unnamed constant";
2266 /* Check lower bound. */
2267 tmp = gfc_conv_array_lbound (descriptor, n);
2268 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
2270 asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded"
2271 "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
2273 asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
2274 gfc_msg_fault, n+1);
2275 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2276 fold_convert (long_integer_type_node, index),
2277 fold_convert (long_integer_type_node, tmp));
2280 /* Check upper bound. */
2283 tmp = gfc_conv_array_ubound (descriptor, n);
2284 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
2286 asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
2287 " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
2289 asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
2290 gfc_msg_fault, n+1);
2291 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2292 fold_convert (long_integer_type_node, index),
2293 fold_convert (long_integer_type_node, tmp));
2301 /* Return the offset for an index. Performs bound checking for elemental
2302 dimensions. Single element references are processed separately. */
2305 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2306 gfc_array_ref * ar, tree stride)
2312 /* Get the index into the array for this dimension. */
2315 gcc_assert (ar->type != AR_ELEMENT);
2316 switch (ar->dimen_type[dim])
2319 /* Elemental dimension. */
2320 gcc_assert (info->subscript[dim]
2321 && info->subscript[dim]->type == GFC_SS_SCALAR);
2322 /* We've already translated this value outside the loop. */
2323 index = info->subscript[dim]->data.scalar.expr;
2325 index = gfc_trans_array_bound_check (se, info->descriptor,
2326 index, dim, &ar->where,
2327 (ar->as->type != AS_ASSUMED_SIZE
2328 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2332 gcc_assert (info && se->loop);
2333 gcc_assert (info->subscript[dim]
2334 && info->subscript[dim]->type == GFC_SS_VECTOR);
2335 desc = info->subscript[dim]->data.info.descriptor;
2337 /* Get a zero-based index into the vector. */
2338 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2339 se->loop->loopvar[i], se->loop->from[i]);
2341 /* Multiply the index by the stride. */
2342 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2343 index, gfc_conv_array_stride (desc, 0));
2345 /* Read the vector to get an index into info->descriptor. */
2346 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
2347 index = gfc_build_array_ref (data, index, NULL);
2348 index = gfc_evaluate_now (index, &se->pre);
2350 /* Do any bounds checking on the final info->descriptor index. */
2351 index = gfc_trans_array_bound_check (se, info->descriptor,
2352 index, dim, &ar->where,
2353 (ar->as->type != AS_ASSUMED_SIZE
2354 && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2358 /* Scalarized dimension. */
2359 gcc_assert (info && se->loop);
2361 /* Multiply the loop variable by the stride and delta. */
2362 index = se->loop->loopvar[i];
2363 if (!integer_onep (info->stride[i]))
2364 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2366 if (!integer_zerop (info->delta[i]))
2367 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2377 /* Temporary array or derived type component. */
2378 gcc_assert (se->loop);
2379 index = se->loop->loopvar[se->loop->order[i]];
2380 if (!integer_zerop (info->delta[i]))
2381 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2382 index, info->delta[i]);
2385 /* Multiply by the stride. */
2386 if (!integer_onep (stride))
2387 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2393 /* Build a scalarized reference to an array. */
2396 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2399 tree decl = NULL_TREE;
2404 info = &se->ss->data.info;
2406 n = se->loop->order[0];
2410 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2412 /* Add the offset for this dimension to the stored offset for all other
2414 if (!integer_zerop (info->offset))
2415 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2417 if (se->ss->expr && is_subref_array (se->ss->expr))
2418 decl = se->ss->expr->symtree->n.sym->backend_decl;
2420 tmp = build_fold_indirect_ref (info->data);
2421 se->expr = gfc_build_array_ref (tmp, index, decl);
2425 /* Translate access of temporary array. */
2428 gfc_conv_tmp_array_ref (gfc_se * se)
2430 se->string_length = se->ss->string_length;
2431 gfc_conv_scalarized_array_ref (se, NULL);
2435 /* Build an array reference. se->expr already holds the array descriptor.
2436 This should be either a variable, indirect variable reference or component
2437 reference. For arrays which do not have a descriptor, se->expr will be
2439 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2442 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2451 /* Handle scalarized references separately. */
2452 if (ar->type != AR_ELEMENT)
2454 gfc_conv_scalarized_array_ref (se, ar);
2455 gfc_advance_se_ss_chain (se);
2459 index = gfc_index_zero_node;
2461 /* Calculate the offsets from all the dimensions. */
2462 for (n = 0; n < ar->dimen; n++)
2464 /* Calculate the index for this dimension. */
2465 gfc_init_se (&indexse, se);
2466 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2467 gfc_add_block_to_block (&se->pre, &indexse.pre);
2469 if (flag_bounds_check)
2471 /* Check array bounds. */
2475 /* Evaluate the indexse.expr only once. */
2476 indexse.expr = save_expr (indexse.expr);
2479 tmp = gfc_conv_array_lbound (se->expr, n);
2480 cond = fold_build2 (LT_EXPR, boolean_type_node,
2482 asprintf (&msg, "%s for array '%s', "
2483 "lower bound of dimension %d exceeded (%%ld < %%ld)",
2484 gfc_msg_fault, sym->name, n+1);
2485 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2486 fold_convert (long_integer_type_node,
2488 fold_convert (long_integer_type_node, tmp));
2491 /* Upper bound, but not for the last dimension of assumed-size
2493 if (n < ar->dimen - 1
2494 || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2496 tmp = gfc_conv_array_ubound (se->expr, n);
2497 cond = fold_build2 (GT_EXPR, boolean_type_node,
2499 asprintf (&msg, "%s for array '%s', "
2500 "upper bound of dimension %d exceeded (%%ld > %%ld)",
2501 gfc_msg_fault, sym->name, n+1);
2502 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2503 fold_convert (long_integer_type_node,
2505 fold_convert (long_integer_type_node, tmp));
2510 /* Multiply the index by the stride. */
2511 stride = gfc_conv_array_stride (se->expr, n);
2512 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2515 /* And add it to the total. */
2516 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2519 tmp = gfc_conv_array_offset (se->expr);
2520 if (!integer_zerop (tmp))
2521 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2523 /* Access the calculated element. */
2524 tmp = gfc_conv_array_data (se->expr);
2525 tmp = build_fold_indirect_ref (tmp);
2526 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2530 /* Generate the code to be executed immediately before entering a
2531 scalarization loop. */
2534 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2535 stmtblock_t * pblock)
2544 /* This code will be executed before entering the scalarization loop
2545 for this dimension. */
2546 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2548 if ((ss->useflags & flag) == 0)
2551 if (ss->type != GFC_SS_SECTION
2552 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2553 && ss->type != GFC_SS_COMPONENT)
2556 info = &ss->data.info;
2558 if (dim >= info->dimen)
2561 if (dim == info->dimen - 1)
2563 /* For the outermost loop calculate the offset due to any
2564 elemental dimensions. It will have been initialized with the
2565 base offset of the array. */
2568 for (i = 0; i < info->ref->u.ar.dimen; i++)
2570 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2573 gfc_init_se (&se, NULL);
2575 se.expr = info->descriptor;
2576 stride = gfc_conv_array_stride (info->descriptor, i);
2577 index = gfc_conv_array_index_offset (&se, info, i, -1,
2580 gfc_add_block_to_block (pblock, &se.pre);
2582 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2583 info->offset, index);
2584 info->offset = gfc_evaluate_now (info->offset, pblock);
2588 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2591 stride = gfc_conv_array_stride (info->descriptor, 0);
2593 /* Calculate the stride of the innermost loop. Hopefully this will
2594 allow the backend optimizers to do their stuff more effectively.
2596 info->stride0 = gfc_evaluate_now (stride, pblock);
2600 /* Add the offset for the previous loop dimension. */
2605 ar = &info->ref->u.ar;
2606 i = loop->order[dim + 1];
2614 gfc_init_se (&se, NULL);
2616 se.expr = info->descriptor;
2617 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2618 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2620 gfc_add_block_to_block (pblock, &se.pre);
2621 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2622 info->offset, index);
2623 info->offset = gfc_evaluate_now (info->offset, pblock);
2626 /* Remember this offset for the second loop. */
2627 if (dim == loop->temp_dim - 1)
2628 info->saved_offset = info->offset;
2633 /* Start a scalarized expression. Creates a scope and declares loop
2637 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2643 gcc_assert (!loop->array_parameter);
2645 for (dim = loop->dimen - 1; dim >= 0; dim--)
2647 n = loop->order[dim];
2649 gfc_start_block (&loop->code[n]);
2651 /* Create the loop variable. */
2652 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2654 if (dim < loop->temp_dim)
2658 /* Calculate values that will be constant within this loop. */
2659 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2661 gfc_start_block (pbody);
2665 /* Generates the actual loop code for a scalarization loop. */
2668 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2669 stmtblock_t * pbody)
2677 loopbody = gfc_finish_block (pbody);
2679 /* Initialize the loopvar. */
2680 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2682 exit_label = gfc_build_label_decl (NULL_TREE);
2684 /* Generate the loop body. */
2685 gfc_init_block (&block);
2687 /* The exit condition. */
2688 cond = fold_build2 (GT_EXPR, boolean_type_node,
2689 loop->loopvar[n], loop->to[n]);
2690 tmp = build1_v (GOTO_EXPR, exit_label);
2691 TREE_USED (exit_label) = 1;
2692 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2693 gfc_add_expr_to_block (&block, tmp);
2695 /* The main body. */
2696 gfc_add_expr_to_block (&block, loopbody);
2698 /* Increment the loopvar. */
2699 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2700 loop->loopvar[n], gfc_index_one_node);
2701 gfc_add_modify (&block, loop->loopvar[n], tmp);
2703 /* Build the loop. */
2704 tmp = gfc_finish_block (&block);
2705 tmp = build1_v (LOOP_EXPR, tmp);
2706 gfc_add_expr_to_block (&loop->code[n], tmp);
2708 /* Add the exit label. */
2709 tmp = build1_v (LABEL_EXPR, exit_label);
2710 gfc_add_expr_to_block (&loop->code[n], tmp);
2714 /* Finishes and generates the loops for a scalarized expression. */
2717 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2722 stmtblock_t *pblock;
2726 /* Generate the loops. */
2727 for (dim = 0; dim < loop->dimen; dim++)
2729 n = loop->order[dim];
2730 gfc_trans_scalarized_loop_end (loop, n, pblock);
2731 loop->loopvar[n] = NULL_TREE;
2732 pblock = &loop->code[n];
2735 tmp = gfc_finish_block (pblock);
2736 gfc_add_expr_to_block (&loop->pre, tmp);
2738 /* Clear all the used flags. */
2739 for (ss = loop->ss; ss; ss = ss->loop_chain)
2744 /* Finish the main body of a scalarized expression, and start the secondary
2748 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2752 stmtblock_t *pblock;
2756 /* We finish as many loops as are used by the temporary. */
2757 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2759 n = loop->order[dim];
2760 gfc_trans_scalarized_loop_end (loop, n, pblock);
2761 loop->loopvar[n] = NULL_TREE;
2762 pblock = &loop->code[n];
2765 /* We don't want to finish the outermost loop entirely. */
2766 n = loop->order[loop->temp_dim - 1];
2767 gfc_trans_scalarized_loop_end (loop, n, pblock);
2769 /* Restore the initial offsets. */
2770 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2772 if ((ss->useflags & 2) == 0)
2775 if (ss->type != GFC_SS_SECTION
2776 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2777 && ss->type != GFC_SS_COMPONENT)
2780 ss->data.info.offset = ss->data.info.saved_offset;
2783 /* Restart all the inner loops we just finished. */
2784 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2786 n = loop->order[dim];
2788 gfc_start_block (&loop->code[n]);
2790 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2792 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2795 /* Start a block for the secondary copying code. */
2796 gfc_start_block (body);
2800 /* Calculate the upper bound of an array section. */
2803 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2812 gcc_assert (ss->type == GFC_SS_SECTION);
2814 info = &ss->data.info;
2817 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2818 /* We'll calculate the upper bound once we have access to the
2819 vector's descriptor. */
2822 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2823 desc = info->descriptor;
2824 end = info->ref->u.ar.end[dim];
2828 /* The upper bound was specified. */
2829 gfc_init_se (&se, NULL);
2830 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2831 gfc_add_block_to_block (pblock, &se.pre);
2836 /* No upper bound was specified, so use the bound of the array. */
2837 bound = gfc_conv_array_ubound (desc, dim);
2844 /* Calculate the lower bound of an array section. */
2847 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2857 gcc_assert (ss->type == GFC_SS_SECTION);
2859 info = &ss->data.info;
2862 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2864 /* We use a zero-based index to access the vector. */
2865 info->start[n] = gfc_index_zero_node;
2866 info->end[n] = gfc_index_zero_node;
2867 info->stride[n] = gfc_index_one_node;
2871 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2872 desc = info->descriptor;
2873 start = info->ref->u.ar.start[dim];
2874 end = info->ref->u.ar.end[dim];
2875 stride = info->ref->u.ar.stride[dim];
2877 /* Calculate the start of the range. For vector subscripts this will
2878 be the range of the vector. */
2881 /* Specified section start. */
2882 gfc_init_se (&se, NULL);
2883 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2884 gfc_add_block_to_block (&loop->pre, &se.pre);
2885 info->start[n] = se.expr;
2889 /* No lower bound specified so use the bound of the array. */
2890 info->start[n] = gfc_conv_array_lbound (desc, dim);
2892 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2894 /* Similarly calculate the end. Although this is not used in the
2895 scalarizer, it is needed when checking bounds and where the end
2896 is an expression with side-effects. */
2899 /* Specified section start. */
2900 gfc_init_se (&se, NULL);
2901 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2902 gfc_add_block_to_block (&loop->pre, &se.pre);
2903 info->end[n] = se.expr;
2907 /* No upper bound specified so use the bound of the array. */
2908 info->end[n] = gfc_conv_array_ubound (desc, dim);
2910 info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
2912 /* Calculate the stride. */
2914 info->stride[n] = gfc_index_one_node;
2917 gfc_init_se (&se, NULL);
2918 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2919 gfc_add_block_to_block (&loop->pre, &se.pre);
2920 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2925 /* Calculates the range start and stride for a SS chain. Also gets the
2926 descriptor and data pointer. The range of vector subscripts is the size
2927 of the vector. Array bounds are also checked. */
2930 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2938 /* Determine the rank of the loop. */
2940 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2944 case GFC_SS_SECTION:
2945 case GFC_SS_CONSTRUCTOR:
2946 case GFC_SS_FUNCTION:
2947 case GFC_SS_COMPONENT:
2948 loop->dimen = ss->data.info.dimen;
2951 /* As usual, lbound and ubound are exceptions!. */
2952 case GFC_SS_INTRINSIC:
2953 switch (ss->expr->value.function.isym->id)
2955 case GFC_ISYM_LBOUND:
2956 case GFC_ISYM_UBOUND:
2957 loop->dimen = ss->data.info.dimen;
2968 /* We should have determined the rank of the expression by now. If
2969 not, that's bad news. */
2970 gcc_assert (loop->dimen != 0);
2972 /* Loop over all the SS in the chain. */
2973 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2975 if (ss->expr && ss->expr->shape && !ss->shape)
2976 ss->shape = ss->expr->shape;
2980 case GFC_SS_SECTION:
2981 /* Get the descriptor for the array. */
2982 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2984 for (n = 0; n < ss->data.info.dimen; n++)
2985 gfc_conv_section_startstride (loop, ss, n);
2988 case GFC_SS_INTRINSIC:
2989 switch (ss->expr->value.function.isym->id)
2991 /* Fall through to supply start and stride. */
2992 case GFC_ISYM_LBOUND:
2993 case GFC_ISYM_UBOUND:
2999 case GFC_SS_CONSTRUCTOR:
3000 case GFC_SS_FUNCTION:
3001 for (n = 0; n < ss->data.info.dimen; n++)
3003 ss->data.info.start[n] = gfc_index_zero_node;
3004 ss->data.info.end[n] = gfc_index_zero_node;
3005 ss->data.info.stride[n] = gfc_index_one_node;
3014 /* The rest is just runtime bound checking. */
3015 if (flag_bounds_check)
3018 tree lbound, ubound;
3020 tree size[GFC_MAX_DIMENSIONS];
3021 tree stride_pos, stride_neg, non_zerosized, tmp2;
3026 gfc_start_block (&block);
3028 for (n = 0; n < loop->dimen; n++)
3029 size[n] = NULL_TREE;
3031 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3035 if (ss->type != GFC_SS_SECTION)
3038 gfc_start_block (&inner);
3040 /* TODO: range checking for mapped dimensions. */
3041 info = &ss->data.info;
3043 /* This code only checks ranges. Elemental and vector
3044 dimensions are checked later. */
3045 for (n = 0; n < loop->dimen; n++)
3050 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3053 if (dim == info->ref->u.ar.dimen - 1
3054 && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3055 || info->ref->u.ar.as->cp_was_assumed))
3056 check_upper = false;
3060 /* Zero stride is not allowed. */
3061 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3062 gfc_index_zero_node);
3063 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3064 "of array '%s'", info->dim[n]+1,
3065 ss->expr->symtree->name);
3066 gfc_trans_runtime_check (true, false, tmp, &inner,
3067 &ss->expr->where, msg);
3070 desc = ss->data.info.descriptor;
3072 /* This is the run-time equivalent of resolve.c's
3073 check_dimension(). The logical is more readable there
3074 than it is here, with all the trees. */
3075 lbound = gfc_conv_array_lbound (desc, dim);
3078 ubound = gfc_conv_array_ubound (desc, dim);
3082 /* non_zerosized is true when the selected range is not
3084 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3085 info->stride[n], gfc_index_zero_node);
3086 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3088 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3091 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3092 info->stride[n], gfc_index_zero_node);
3093 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3095 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3097 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3098 stride_pos, stride_neg);
3100 /* Check the start of the range against the lower and upper
3101 bounds of the array, if the range is not empty. */
3102 tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
3104 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3105 non_zerosized, tmp);
3106 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3107 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3108 info->dim[n]+1, ss->expr->symtree->name);
3109 gfc_trans_runtime_check (true, false, tmp, &inner,
3110 &ss->expr->where, msg,
3111 fold_convert (long_integer_type_node,
3113 fold_convert (long_integer_type_node,
3119 tmp = fold_build2 (GT_EXPR, boolean_type_node,
3120 info->start[n], ubound);
3121 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3122 non_zerosized, tmp);
3123 asprintf (&msg, "%s, upper bound of dimension %d of array "
3124 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3125 info->dim[n]+1, ss->expr->symtree->name);
3126 gfc_trans_runtime_check (true, false, tmp, &inner,
3127 &ss->expr->where, msg,
3128 fold_convert (long_integer_type_node, info->start[n]),
3129 fold_convert (long_integer_type_node, ubound));
3133 /* Compute the last element of the range, which is not
3134 necessarily "end" (think 0:5:3, which doesn't contain 5)
3135 and check it against both lower and upper bounds. */
3136 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3138 tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
3140 tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3143 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
3144 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3145 non_zerosized, tmp);
3146 asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
3147 " exceeded (%%ld < %%ld)", gfc_msg_fault,
3148 info->dim[n]+1, ss->expr->symtree->name);
3149 gfc_trans_runtime_check (true, false, tmp, &inner,
3150 &ss->expr->where, msg,
3151 fold_convert (long_integer_type_node,
3153 fold_convert (long_integer_type_node,
3159 tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
3160 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3161 non_zerosized, tmp);
3162 asprintf (&msg, "%s, upper bound of dimension %d of array "
3163 "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
3164 info->dim[n]+1, ss->expr->symtree->name);
3165 gfc_trans_runtime_check (true, false, tmp, &inner,
3166 &ss->expr->where, msg,
3167 fold_convert (long_integer_type_node, tmp2),
3168 fold_convert (long_integer_type_node, ubound));
3172 /* Check the section sizes match. */
3173 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3175 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3177 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3178 build_int_cst (gfc_array_index_type, 0));
3179 /* We remember the size of the first section, and check all the
3180 others against this. */
3185 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3186 asprintf (&msg, "%s, size mismatch for dimension %d "
3187 "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3188 info->dim[n]+1, ss->expr->symtree->name);
3189 gfc_trans_runtime_check (true, false, tmp3, &inner,
3190 &ss->expr->where, msg,
3191 fold_convert (long_integer_type_node, tmp),
3192 fold_convert (long_integer_type_node, size[n]));
3196 size[n] = gfc_evaluate_now (tmp, &inner);
3199 tmp = gfc_finish_block (&inner);
3201 /* For optional arguments, only check bounds if the argument is
3203 if (ss->expr->symtree->n.sym->attr.optional
3204 || ss->expr->symtree->n.sym->attr.not_always_present)
3205 tmp = build3_v (COND_EXPR,
3206 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3207 tmp, build_empty_stmt ());
3209 gfc_add_expr_to_block (&block, tmp);
3213 tmp = gfc_finish_block (&block);
3214 gfc_add_expr_to_block (&loop->pre, tmp);
3219 /* Return true if the two SS could be aliased, i.e. both point to the same data
3221 /* TODO: resolve aliases based on frontend expressions. */
3224 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3231 lsym = lss->expr->symtree->n.sym;
3232 rsym = rss->expr->symtree->n.sym;
3233 if (gfc_symbols_could_alias (lsym, rsym))
3236 if (rsym->ts.type != BT_DERIVED
3237 && lsym->ts.type != BT_DERIVED)
3240 /* For derived types we must check all the component types. We can ignore
3241 array references as these will have the same base type as the previous
3243 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3245 if (lref->type != REF_COMPONENT)
3248 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3251 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3254 if (rref->type != REF_COMPONENT)
3257 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3262 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3264 if (rref->type != REF_COMPONENT)
3267 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3275 /* Resolve array data dependencies. Creates a temporary if required. */
3276 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3280 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3290 loop->temp_ss = NULL;
3291 aref = dest->data.info.ref;
3294 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3296 if (ss->type != GFC_SS_SECTION)
3299 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3301 if (gfc_could_be_alias (dest, ss)
3302 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3310 lref = dest->expr->ref;
3311 rref = ss->expr->ref;
3313 nDepend = gfc_dep_resolver (lref, rref);
3317 /* TODO : loop shifting. */
3320 /* Mark the dimensions for LOOP SHIFTING */
3321 for (n = 0; n < loop->dimen; n++)
3323 int dim = dest->data.info.dim[n];
3325 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3327 else if (! gfc_is_same_range (&lref->u.ar,
3328 &rref->u.ar, dim, 0))
3332 /* Put all the dimensions with dependencies in the
3335 for (n = 0; n < loop->dimen; n++)
3337 gcc_assert (loop->order[n] == n);
3339 loop->order[dim++] = n;
3342 for (n = 0; n < loop->dimen; n++)
3345 loop->order[dim++] = n;
3348 gcc_assert (dim == loop->dimen);
3357 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3358 if (GFC_ARRAY_TYPE_P (base_type)
3359 || GFC_DESCRIPTOR_TYPE_P (base_type))
3360 base_type = gfc_get_element_type (base_type);
3361 loop->temp_ss = gfc_get_ss ();
3362 loop->temp_ss->type = GFC_SS_TEMP;
3363 loop->temp_ss->data.temp.type = base_type;
3364 loop->temp_ss->string_length = dest->string_length;
3365 loop->temp_ss->data.temp.dimen = loop->dimen;
3366 loop->temp_ss->next = gfc_ss_terminator;
3367 gfc_add_ss_to_loop (loop, loop->temp_ss);
3370 loop->temp_ss = NULL;
3374 /* Initialize the scalarization loop. Creates the loop variables. Determines
3375 the range of the loop variables. Creates a temporary if required.
3376 Calculates how to transform from loop variables to array indices for each
3377 expression. Also generates code for scalar expressions which have been
3378 moved outside the loop. */
3381 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3386 gfc_ss_info *specinfo;
3390 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3391 bool dynamic[GFC_MAX_DIMENSIONS];
3397 for (n = 0; n < loop->dimen; n++)
3401 /* We use one SS term, and use that to determine the bounds of the
3402 loop for this dimension. We try to pick the simplest term. */
3403 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3407 /* The frontend has worked out the size for us. */
3408 if (!loopspec[n] || !loopspec[n]->shape
3409 || !integer_zerop (loopspec[n]->data.info.start[n]))
3410 /* Prefer zero-based descriptors if possible. */
3415 if (ss->type == GFC_SS_CONSTRUCTOR)
3417 /* An unknown size constructor will always be rank one.
3418 Higher rank constructors will either have known shape,
3419 or still be wrapped in a call to reshape. */
3420 gcc_assert (loop->dimen == 1);
3422 /* Always prefer to use the constructor bounds if the size
3423 can be determined at compile time. Prefer not to otherwise,
3424 since the general case involves realloc, and it's better to
3425 avoid that overhead if possible. */
3426 c = ss->expr->value.constructor;
3427 dynamic[n] = gfc_get_array_constructor_size (&i, c);
3428 if (!dynamic[n] || !loopspec[n])
3433 /* TODO: Pick the best bound if we have a choice between a
3434 function and something else. */
3435 if (ss->type == GFC_SS_FUNCTION)
3441 if (ss->type != GFC_SS_SECTION)
3445 specinfo = &loopspec[n]->data.info;
3448 info = &ss->data.info;
3452 /* Criteria for choosing a loop specifier (most important first):
3453 doesn't need realloc
3459 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3461 else if (integer_onep (info->stride[n])
3462 && !integer_onep (specinfo->stride[n]))
3464 else if (INTEGER_CST_P (info->stride[n])
3465 && !INTEGER_CST_P (specinfo->stride[n]))
3467 else if (INTEGER_CST_P (info->start[n])
3468 && !INTEGER_CST_P (specinfo->start[n]))
3470 /* We don't work out the upper bound.
3471 else if (INTEGER_CST_P (info->finish[n])
3472 && ! INTEGER_CST_P (specinfo->finish[n]))
3473 loopspec[n] = ss; */
3476 /* We should have found the scalarization loop specifier. If not,
3478 gcc_assert (loopspec[n]);
3480 info = &loopspec[n]->data.info;
3482 /* Set the extents of this range. */
3483 cshape = loopspec[n]->shape;
3484 if (cshape && INTEGER_CST_P (info->start[n])
3485 && INTEGER_CST_P (info->stride[n]))
3487 loop->from[n] = info->start[n];
3488 mpz_set (i, cshape[n]);
3489 mpz_sub_ui (i, i, 1);
3490 /* To = from + (size - 1) * stride. */
3491 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3492 if (!integer_onep (info->stride[n]))
3493 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3494 tmp, info->stride[n]);
3495 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3496 loop->from[n], tmp);
3500 loop->from[n] = info->start[n];
3501 switch (loopspec[n]->type)
3503 case GFC_SS_CONSTRUCTOR:
3504 /* The upper bound is calculated when we expand the
3506 gcc_assert (loop->to[n] == NULL_TREE);
3509 case GFC_SS_SECTION:
3510 /* Use the end expression if it exists and is not constant,
3511 so that it is only evaluated once. */
3512 if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3513 loop->to[n] = info->end[n];
3515 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3519 case GFC_SS_FUNCTION:
3520 /* The loop bound will be set when we generate the call. */
3521 gcc_assert (loop->to[n] == NULL_TREE);
3529 /* Transform everything so we have a simple incrementing variable. */
3530 if (integer_onep (info->stride[n]))
3531 info->delta[n] = gfc_index_zero_node;
3534 /* Set the delta for this section. */
3535 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3536 /* Number of iterations is (end - start + step) / step.
3537 with start = 0, this simplifies to
3539 for (i = 0; i<=last; i++){...}; */
3540 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3541 loop->to[n], loop->from[n]);
3542 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3543 tmp, info->stride[n]);
3544 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3545 build_int_cst (gfc_array_index_type, -1));
3546 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3547 /* Make the loop variable start at 0. */
3548 loop->from[n] = gfc_index_zero_node;
3552 /* Add all the scalar code that can be taken out of the loops.
3553 This may include calculating the loop bounds, so do it before
3554 allocating the temporary. */
3555 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3557 /* If we want a temporary then create it. */
3558 if (loop->temp_ss != NULL)
3560 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3562 /* Make absolutely sure that this is a complete type. */
3563 if (loop->temp_ss->string_length)
3564 loop->temp_ss->data.temp.type
3565 = gfc_get_character_type_len_for_eltype
3566 (TREE_TYPE (loop->temp_ss->data.temp.type),
3567 loop->temp_ss->string_length);
3569 tmp = loop->temp_ss->data.temp.type;
3570 len = loop->temp_ss->string_length;
3571 n = loop->temp_ss->data.temp.dimen;
3572 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3573 loop->temp_ss->type = GFC_SS_SECTION;
3574 loop->temp_ss->data.info.dimen = n;
3575 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3576 &loop->temp_ss->data.info, tmp, NULL_TREE,
3577 false, true, false, where);
3580 for (n = 0; n < loop->temp_dim; n++)
3581 loopspec[loop->order[n]] = NULL;
3585 /* For array parameters we don't have loop variables, so don't calculate the
3587 if (loop->array_parameter)
3590 /* Calculate the translation from loop variables to array indices. */
3591 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3593 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3594 && ss->type != GFC_SS_CONSTRUCTOR)
3598 info = &ss->data.info;
3600 for (n = 0; n < info->dimen; n++)
3604 /* If we are specifying the range the delta is already set. */
3605 if (loopspec[n] != ss)
3607 /* Calculate the offset relative to the loop variable.
3608 First multiply by the stride. */
3609 tmp = loop->from[n];
3610 if (!integer_onep (info->stride[n]))
3611 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3612 tmp, info->stride[n]);
3614 /* Then subtract this from our starting value. */
3615 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3616 info->start[n], tmp);
3618 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3625 /* Fills in an array descriptor, and returns the size of the array. The size
3626 will be a simple_val, ie a variable or a constant. Also calculates the
3627 offset of the base. Returns the size of the array.
3631 for (n = 0; n < rank; n++)
3633 a.lbound[n] = specified_lower_bound;
3634 offset = offset + a.lbond[n] * stride;
3636 a.ubound[n] = specified_upper_bound;
3637 a.stride[n] = stride;
3638 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3639 stride = stride * size;
3646 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3647 gfc_expr ** lower, gfc_expr ** upper,
3648 stmtblock_t * pblock)
3660 stmtblock_t thenblock;
3661 stmtblock_t elseblock;
3666 type = TREE_TYPE (descriptor);
3668 stride = gfc_index_one_node;
3669 offset = gfc_index_zero_node;
3671 /* Set the dtype. */
3672 tmp = gfc_conv_descriptor_dtype (descriptor);
3673 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3675 or_expr = NULL_TREE;
3677 for (n = 0; n < rank; n++)
3679 /* We have 3 possibilities for determining the size of the array:
3680 lower == NULL => lbound = 1, ubound = upper[n]
3681 upper[n] = NULL => lbound = 1, ubound = lower[n]
3682 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3685 /* Set lower bound. */
3686 gfc_init_se (&se, NULL);
3688 se.expr = gfc_index_one_node;
3691 gcc_assert (lower[n]);
3694 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3695 gfc_add_block_to_block (pblock, &se.pre);
3699 se.expr = gfc_index_one_node;
3703 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
3704 gfc_add_modify (pblock, tmp, se.expr);
3706 /* Work out the offset for this component. */
3707 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3708 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3710 /* Start the calculation for the size of this dimension. */
3711 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3712 gfc_index_one_node, se.expr);
3714 /* Set upper bound. */
3715 gfc_init_se (&se, NULL);
3716 gcc_assert (ubound);
3717 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3718 gfc_add_block_to_block (pblock, &se.pre);
3720 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3721 gfc_add_modify (pblock, tmp, se.expr);
3723 /* Store the stride. */
3724 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3725 gfc_add_modify (pblock, tmp, stride);
3727 /* Calculate the size of this dimension. */
3728 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3730 /* Check whether the size for this dimension is negative. */
3731 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3732 gfc_index_zero_node);
3736 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3738 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3739 gfc_index_zero_node, size);
3741 /* Multiply the stride by the number of elements in this dimension. */
3742 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3743 stride = gfc_evaluate_now (stride, pblock);
3746 /* The stride is the number of elements in the array, so multiply by the
3747 size of an element to get the total size. */
3748 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3749 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3750 fold_convert (gfc_array_index_type, tmp));
3752 if (poffset != NULL)
3754 offset = gfc_evaluate_now (offset, pblock);
3758 if (integer_zerop (or_expr))
3760 if (integer_onep (or_expr))
3761 return gfc_index_zero_node;
3763 var = gfc_create_var (TREE_TYPE (size), "size");
3764 gfc_start_block (&thenblock);
3765 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3766 thencase = gfc_finish_block (&thenblock);
3768 gfc_start_block (&elseblock);
3769 gfc_add_modify (&elseblock, var, size);
3770 elsecase = gfc_finish_block (&elseblock);
3772 tmp = gfc_evaluate_now (or_expr, pblock);
3773 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3774 gfc_add_expr_to_block (pblock, tmp);
3780 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3781 the work for an ALLOCATE statement. */
3785 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3793 gfc_ref *ref, *prev_ref = NULL;
3794 bool allocatable_array;
3798 /* Find the last reference in the chain. */
3799 while (ref && ref->next != NULL)
3801 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3806 if (ref == NULL || ref->type != REF_ARRAY)
3810 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3812 allocatable_array = prev_ref->u.c.component->attr.allocatable;
3814 /* Figure out the size of the array. */
3815 switch (ref->u.ar.type)
3819 upper = ref->u.ar.start;
3823 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3825 lower = ref->u.ar.as->lower;
3826 upper = ref->u.ar.as->upper;
3830 lower = ref->u.ar.start;
3831 upper = ref->u.ar.end;
3839 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3840 lower, upper, &se->pre);
3842 /* Allocate memory to store the data. */
3843 pointer = gfc_conv_descriptor_data_get (se->expr);
3844 STRIP_NOPS (pointer);
3846 /* The allocate_array variants take the old pointer as first argument. */
3847 if (allocatable_array)
3848 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
3850 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
3851 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
3852 gfc_add_expr_to_block (&se->pre, tmp);
3854 tmp = gfc_conv_descriptor_offset (se->expr);
3855 gfc_add_modify (&se->pre, tmp, offset);
3857 if (expr->ts.type == BT_DERIVED
3858 && expr->ts.derived->attr.alloc_comp)
3860 tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
3861 ref->u.ar.as->rank);
3862 gfc_add_expr_to_block (&se->pre, tmp);
3869 /* Deallocate an array variable. Also used when an allocated variable goes
3874 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
3880 gfc_start_block (&block);
3881 /* Get a pointer to the data. */
3882 var = gfc_conv_descriptor_data_get (descriptor);
3885 /* Parameter is the address of the data component. */
3886 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
3887 gfc_add_expr_to_block (&block, tmp);
3889 /* Zero the data pointer. */
3890 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
3891 var, build_int_cst (TREE_TYPE (var), 0));
3892 gfc_add_expr_to_block (&block, tmp);
3894 return gfc_finish_block (&block);
3898 /* Create an array constructor from an initialization expression.
3899 We assume the frontend already did any expansions and conversions. */
3902 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3909 unsigned HOST_WIDE_INT lo;
3911 VEC(constructor_elt,gc) *v = NULL;
3913 switch (expr->expr_type)
3916 case EXPR_STRUCTURE:
3917 /* A single scalar or derived type value. Create an array with all
3918 elements equal to that value. */
3919 gfc_init_se (&se, NULL);
3921 if (expr->expr_type == EXPR_CONSTANT)
3922 gfc_conv_constant (&se, expr);
3924 gfc_conv_structure (&se, expr, 1);
3926 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3927 gcc_assert (tmp && INTEGER_CST_P (tmp));
3928 hi = TREE_INT_CST_HIGH (tmp);
3929 lo = TREE_INT_CST_LOW (tmp);
3933 /* This will probably eat buckets of memory for large arrays. */
3934 while (hi != 0 || lo != 0)
3936 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3944 /* Create a vector of all the elements. */
3945 for (c = expr->value.constructor; c; c = c->next)
3949 /* Problems occur when we get something like
3950 integer :: a(lots) = (/(i, i=1, lots)/) */
3951 gfc_error_now ("The number of elements in the array constructor "
3952 "at %L requires an increase of the allowed %d "
3953 "upper limit. See -fmax-array-constructor "
3954 "option", &expr->where,
3955 gfc_option.flag_max_array_constructor);
3958 if (mpz_cmp_si (c->n.offset, 0) != 0)
3959 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3963 if (mpz_cmp_si (c->repeat, 0) != 0)
3967 mpz_set (maxval, c->repeat);
3968 mpz_add (maxval, c->n.offset, maxval);
3969 mpz_sub_ui (maxval, maxval, 1);
3970 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3971 if (mpz_cmp_si (c->n.offset, 0) != 0)
3973 mpz_add_ui (maxval, c->n.offset, 1);
3974 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3977 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3979 range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3985 gfc_init_se (&se, NULL);
3986 switch (c->expr->expr_type)
3989 gfc_conv_constant (&se, c->expr);
3990 if (range == NULL_TREE)
3991 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3994 if (index != NULL_TREE)
3995 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3996 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4000 case EXPR_STRUCTURE:
4001 gfc_conv_structure (&se, c->expr, 1);
4002 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4012 return gfc_build_null_descriptor (type);
4018 /* Create a constructor from the list of elements. */
4019 tmp = build_constructor (type, v);
4020 TREE_CONSTANT (tmp) = 1;
4025 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4026 returns the size (in elements) of the array. */
4029 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4030 stmtblock_t * pblock)
4045 size = gfc_index_one_node;
4046 offset = gfc_index_zero_node;
4047 for (dim = 0; dim < as->rank; dim++)
4049 /* Evaluate non-constant array bound expressions. */
4050 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4051 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4053 gfc_init_se (&se, NULL);
4054 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4055 gfc_add_block_to_block (pblock, &se.pre);
4056 gfc_add_modify (pblock, lbound, se.expr);
4058 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4059 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4061 gfc_init_se (&se, NULL);
4062 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4063 gfc_add_block_to_block (pblock, &se.pre);
4064 gfc_add_modify (pblock, ubound, se.expr);
4066 /* The offset of this dimension. offset = offset - lbound * stride. */
4067 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4068 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4070 /* The size of this dimension, and the stride of the next. */
4071 if (dim + 1 < as->rank)
4072 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4074 stride = GFC_TYPE_ARRAY_SIZE (type);
4076 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4078 /* Calculate stride = size * (ubound + 1 - lbound). */
4079 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4080 gfc_index_one_node, lbound);
4081 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4082 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4084 gfc_add_modify (pblock, stride, tmp);
4086 stride = gfc_evaluate_now (tmp, pblock);
4088 /* Make sure that negative size arrays are translated
4089 to being zero size. */
4090 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4091 stride, gfc_index_zero_node);
4092 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4093 stride, gfc_index_zero_node);
4094 gfc_add_modify (pblock, stride, tmp);
4100 gfc_trans_vla_type_sizes (sym, pblock);
4107 /* Generate code to initialize/allocate an array variable. */
4110 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
4119 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4121 /* Do nothing for USEd variables. */
4122 if (sym->attr.use_assoc)
4125 type = TREE_TYPE (decl);
4126 gcc_assert (GFC_ARRAY_TYPE_P (type));
4127 onstack = TREE_CODE (type) != POINTER_TYPE;
4129 gfc_start_block (&block);
4131 /* Evaluate character string length. */
4132 if (sym->ts.type == BT_CHARACTER
4133 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4135 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4137 gfc_trans_vla_type_sizes (sym, &block);
4139 /* Emit a DECL_EXPR for this variable, which will cause the
4140 gimplifier to allocate storage, and all that good stuff. */
4141 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4142 gfc_add_expr_to_block (&block, tmp);
4147 gfc_add_expr_to_block (&block, fnbody);
4148 return gfc_finish_block (&block);
4151 type = TREE_TYPE (type);
4153 gcc_assert (!sym->attr.use_assoc);
4154 gcc_assert (!TREE_STATIC (decl));
4155 gcc_assert (!sym->module);
4157 if (sym->ts.type == BT_CHARACTER
4158 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4159 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4161 size = gfc_trans_array_bounds (type, sym, &offset, &block);
4163 /* Don't actually allocate space for Cray Pointees. */
4164 if (sym->attr.cray_pointee)
4166 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4167 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4168 gfc_add_expr_to_block (&block, fnbody);
4169 return gfc_finish_block (&block);
4172 /* The size is the number of elements in the array, so multiply by the
4173 size of an element to get the total size. */
4174 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4175 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4176 fold_convert (gfc_array_index_type, tmp));
4178 /* Allocate memory to hold the data. */
4179 tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
4180 gfc_add_modify (&block, decl, tmp);
4182 /* Set offset of the array. */
4183 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4184 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4187 /* Automatic arrays should not have initializers. */
4188 gcc_assert (!sym->value);
4190 gfc_add_expr_to_block (&block, fnbody);
4192 /* Free the temporary. */
4193 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4194 gfc_add_expr_to_block (&block, tmp);
4196 return gfc_finish_block (&block);
4200 /* Generate entry and exit code for g77 calling convention arrays. */
4203 gfc_trans_g77_array (gfc_symbol * sym, tree body)
4213 gfc_get_backend_locus (&loc);
4214 gfc_set_backend_locus (&sym->declared_at);
4216 /* Descriptor type. */
4217 parm = sym->backend_decl;
4218 type = TREE_TYPE (parm);
4219 gcc_assert (GFC_ARRAY_TYPE_P (type));
4221 gfc_start_block (&block);
4223 if (sym->ts.type == BT_CHARACTER
4224 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4225 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4227 /* Evaluate the bounds of the array. */
4228 gfc_trans_array_bounds (type, sym, &offset, &block);
4230 /* Set the offset. */
4231 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4232 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4234 /* Set the pointer itself if we aren't using the parameter directly. */
4235 if (TREE_CODE (parm) != PARM_DECL)
4237 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4238 gfc_add_modify (&block, parm, tmp);
4240 stmt = gfc_finish_block (&block);
4242 gfc_set_backend_locus (&loc);
4244 gfc_start_block (&block);
4246 /* Add the initialization code to the start of the function. */
4248 if (sym->attr.optional || sym->attr.not_always_present)
4250 tmp = gfc_conv_expr_present (sym);
4251 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4254 gfc_add_expr_to_block (&block, stmt);
4255 gfc_add_expr_to_block (&block, body);
4257 return gfc_finish_block (&block);
4261 /* Modify the descriptor of an array parameter so that it has the
4262 correct lower bound. Also move the upper bound accordingly.
4263 If the array is not packed, it will be copied into a temporary.
4264 For each dimension we set the new lower and upper bounds. Then we copy the
4265 stride and calculate the offset for this dimension. We also work out
4266 what the stride of a packed array would be, and see it the two match.
4267 If the array need repacking, we set the stride to the values we just
4268 calculated, recalculate the offset and copy the array data.
4269 Code is also added to copy the data back at the end of the function.
4273 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
4280 stmtblock_t cleanup;
4288 tree stride, stride2;
4298 /* Do nothing for pointer and allocatable arrays. */
4299 if (sym->attr.pointer || sym->attr.allocatable)
4302 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4303 return gfc_trans_g77_array (sym, body);
4305 gfc_get_backend_locus (&loc);
4306 gfc_set_backend_locus (&sym->declared_at);
4308 /* Descriptor type. */
4309 type = TREE_TYPE (tmpdesc);
4310 gcc_assert (GFC_ARRAY_TYPE_P (type));
4311 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4312 dumdesc = build_fold_indirect_ref (dumdesc);
4313 gfc_start_block (&block);
4315 if (sym->ts.type == BT_CHARACTER
4316 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
4317 gfc_conv_string_length (sym->ts.cl, NULL, &block);
4319 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
4321 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4322 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4324 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4326 /* For non-constant shape arrays we only check if the first dimension
4327 is contiguous. Repacking higher dimensions wouldn't gain us
4328 anything as we still don't know the array stride. */
4329 partial = gfc_create_var (boolean_type_node, "partial");
4330 TREE_USED (partial) = 1;
4331 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4332 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4333 gfc_add_modify (&block, partial, tmp);
4337 partial = NULL_TREE;
4340 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4341 here, however I think it does the right thing. */
4344 /* Set the first stride. */
4345 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
4346 stride = gfc_evaluate_now (stride, &block);
4348 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4349 stride, gfc_index_zero_node);
4350 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4351 gfc_index_one_node, stride);
4352 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4353 gfc_add_modify (&block, stride, tmp);
4355 /* Allow the user to disable array repacking. */
4356 stmt_unpacked = NULL_TREE;
4360 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4361 /* A library call to repack the array if necessary. */
4362 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4363 stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
4365 stride = gfc_index_one_node;
4367 if (gfc_option.warn_array_temp)
4368 gfc_warning ("Creating array temporary at %L", &loc);
4371 /* This is for the case where the array data is used directly without
4372 calling the repack function. */
4373 if (no_repack || partial != NULL_TREE)
4374 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4376 stmt_packed = NULL_TREE;
4378 /* Assign the data pointer. */
4379 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4381 /* Don't repack unknown shape arrays when the first stride is 1. */
4382 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4383 partial, stmt_packed, stmt_unpacked);
4386 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4387 gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
4389 offset = gfc_index_zero_node;
4390 size = gfc_index_one_node;
4392 /* Evaluate the bounds of the array. */
4393 for (n = 0; n < sym->as->rank; n++)
4395 if (checkparm || !sym->as->upper[n])
4397 /* Get the bounds of the actual parameter. */
4398 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
4399 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
4403 dubound = NULL_TREE;
4404 dlbound = NULL_TREE;
4407 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4408 if (!INTEGER_CST_P (lbound))
4410 gfc_init_se (&se, NULL);
4411 gfc_conv_expr_type (&se, sym->as->lower[n],
4412 gfc_array_index_type);
4413 gfc_add_block_to_block (&block, &se.pre);
4414 gfc_add_modify (&block, lbound, se.expr);
4417 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4418 /* Set the desired upper bound. */
4419 if (sym->as->upper[n])
4421 /* We know what we want the upper bound to be. */
4422 if (!INTEGER_CST_P (ubound))
4424 gfc_init_se (&se, NULL);
4425 gfc_conv_expr_type (&se, sym->as->upper[n],
4426 gfc_array_index_type);
4427 gfc_add_block_to_block (&block, &se.pre);
4428 gfc_add_modify (&block, ubound, se.expr);
4431 /* Check the sizes match. */
4434 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4437 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4439 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4441 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
4442 asprintf (&msg, "%s for dimension %d of array '%s'",
4443 gfc_msg_bounds, n+1, sym->name);
4444 gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
4450 /* For assumed shape arrays move the upper bound by the same amount
4451 as the lower bound. */
4452 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4454 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4455 gfc_add_modify (&block, ubound, tmp);
4457 /* The offset of this dimension. offset = offset - lbound * stride. */
4458 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4459 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4461 /* The size of this dimension, and the stride of the next. */
4462 if (n + 1 < sym->as->rank)
4464 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4466 if (no_repack || partial != NULL_TREE)
4469 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
4472 /* Figure out the stride if not a known constant. */
4473 if (!INTEGER_CST_P (stride))
4476 stmt_packed = NULL_TREE;
4479 /* Calculate stride = size * (ubound + 1 - lbound). */
4480 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4481 gfc_index_one_node, lbound);
4482 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4484 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4489 /* Assign the stride. */
4490 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4491 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4492 stmt_unpacked, stmt_packed);
4494 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4495 gfc_add_modify (&block, stride, tmp);
4500 stride = GFC_TYPE_ARRAY_SIZE (type);
4502 if (stride && !INTEGER_CST_P (stride))
4504 /* Calculate size = stride * (ubound + 1 - lbound). */
4505 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4506 gfc_index_one_node, lbound);
4507 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4509 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4510 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4511 gfc_add_modify (&block, stride, tmp);
4516 /* Set the offset. */
4517 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4518 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
4520 gfc_trans_vla_type_sizes (sym, &block);
4522 stmt = gfc_finish_block (&block);
4524 gfc_start_block (&block);
4526 /* Only do the entry/initialization code if the arg is present. */
4527 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4528 optional_arg = (sym->attr.optional
4529 || (sym->ns->proc_name->attr.entry_master
4530 && sym->attr.dummy));
4533 tmp = gfc_conv_expr_present (sym);
4534 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4536 gfc_add_expr_to_block (&block, stmt);
4538 /* Add the main function body. */
4539 gfc_add_expr_to_block (&block, body);
4544 gfc_start_block (&cleanup);
4546 if (sym->attr.intent != INTENT_IN)
4548 /* Copy the data back. */
4549 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4550 gfc_add_expr_to_block (&cleanup, tmp);
4553 /* Free the temporary. */
4554 tmp = gfc_call_free (tmpdesc);
4555 gfc_add_expr_to_block (&cleanup, tmp);
4557 stmt = gfc_finish_block (&cleanup);
4559 /* Only do the cleanup if the array was repacked. */
4560 tmp = build_fold_indirect_ref (dumdesc);
4561 tmp = gfc_conv_descriptor_data_get (tmp);
4562 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4563 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4567 tmp = gfc_conv_expr_present (sym);
4568 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4570 gfc_add_expr_to_block (&block, stmt);
4572 /* We don't need to free any memory allocated by internal_pack as it will
4573 be freed at the end of the function by pop_context. */
4574 return gfc_finish_block (&block);
4578 /* Calculate the overall offset, including subreferences. */
4580 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4581 bool subref, gfc_expr *expr)
4591 /* If offset is NULL and this is not a subreferenced array, there is
4593 if (offset == NULL_TREE)
4596 offset = gfc_index_zero_node;
4601 tmp = gfc_conv_array_data (desc);
4602 tmp = build_fold_indirect_ref (tmp);
4603 tmp = gfc_build_array_ref (tmp, offset, NULL);
4605 /* Offset the data pointer for pointer assignments from arrays with
4606 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4609 /* Go past the array reference. */
4610 for (ref = expr->ref; ref; ref = ref->next)
4611 if (ref->type == REF_ARRAY &&
4612 ref->u.ar.type != AR_ELEMENT)
4618 /* Calculate the offset for each subsequent subreference. */
4619 for (; ref; ref = ref->next)
4624 field = ref->u.c.component->backend_decl;
4625 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4626 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4627 tmp, field, NULL_TREE);
4631 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4632 gfc_init_se (&start, NULL);
4633 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4634 gfc_add_block_to_block (block, &start.pre);
4635 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4639 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4640 && ref->u.ar.type == AR_ELEMENT);
4642 /* TODO - Add bounds checking. */
4643 stride = gfc_index_one_node;
4644 index = gfc_index_zero_node;
4645 for (n = 0; n < ref->u.ar.dimen; n++)
4650 /* Update the index. */
4651 gfc_init_se (&start, NULL);
4652 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4653 itmp = gfc_evaluate_now (start.expr, block);
4654 gfc_init_se (&start, NULL);
4655 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4656 jtmp = gfc_evaluate_now (start.expr, block);
4657 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4658 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4659 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4660 index = gfc_evaluate_now (index, block);
4662 /* Update the stride. */
4663 gfc_init_se (&start, NULL);
4664 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4665 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4666 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4667 gfc_index_one_node, itmp);
4668 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4669 stride = gfc_evaluate_now (stride, block);
4672 /* Apply the index to obtain the array element. */
4673 tmp = gfc_build_array_ref (tmp, index, NULL);
4683 /* Set the target data pointer. */
4684 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4685 gfc_conv_descriptor_data_set (block, parm, offset);
4689 /* gfc_conv_expr_descriptor needs the character length of elemental
4690 functions before the function is called so that the size of the
4691 temporary can be obtained. The only way to do this is to convert
4692 the expression, mapping onto the actual arguments. */
4694 get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
4696 gfc_interface_mapping mapping;
4697 gfc_formal_arglist *formal;
4698 gfc_actual_arglist *arg;
4701 formal = expr->symtree->n.sym->formal;
4702 arg = expr->value.function.actual;
4703 gfc_init_interface_mapping (&mapping);
4705 /* Set se = NULL in the calls to the interface mapping, to suppress any
4707 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4712 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4715 gfc_init_se (&tse, NULL);
4717 /* Build the expression for the character length and convert it. */
4718 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
4720 gfc_add_block_to_block (&se->pre, &tse.pre);
4721 gfc_add_block_to_block (&se->post, &tse.post);
4722 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4723 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4724 build_int_cst (gfc_charlen_type_node, 0));
4725 expr->ts.cl->backend_decl = tse.expr;
4726 gfc_free_interface_mapping (&mapping);
4730 /* Convert an array for passing as an actual argument. Expressions and
4731 vector subscripts are evaluated and stored in a temporary, which is then
4732 passed. For whole arrays the descriptor is passed. For array sections
4733 a modified copy of the descriptor is passed, but using the original data.
4735 This function is also used for array pointer assignments, and there
4738 - se->want_pointer && !se->direct_byref
4739 EXPR is an actual argument. On exit, se->expr contains a
4740 pointer to the array descriptor.
4742 - !se->want_pointer && !se->direct_byref
4743 EXPR is an actual argument to an intrinsic function or the
4744 left-hand side of a pointer assignment. On exit, se->expr
4745 contains the descriptor for EXPR.
4747 - !se->want_pointer && se->direct_byref
4748 EXPR is the right-hand side of a pointer assignment and
4749 se->expr is the descriptor for the previously-evaluated
4750 left-hand side. The function creates an assignment from
4751 EXPR to se->expr. */
4754 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
4767 bool subref_array_target = false;
4769 gcc_assert (ss != gfc_ss_terminator);
4771 /* Special case things we know we can pass easily. */
4772 switch (expr->expr_type)
4775 /* If we have a linear array section, we can pass it directly.
4776 Otherwise we need to copy it into a temporary. */
4778 /* Find the SS for the array section. */
4780 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
4781 secss = secss->next;
4783 gcc_assert (secss != gfc_ss_terminator);
4784 info = &secss->data.info;
4786 /* Get the descriptor for the array. */
4787 gfc_conv_ss_descriptor (&se->pre, secss, 0);
4788 desc = info->descriptor;
4790 subref_array_target = se->direct_byref && is_subref_array (expr);
4791 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
4792 && !subref_array_target;
4796 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
4798 /* Create a new descriptor if the array doesn't have one. */
4801 else if (info->ref->u.ar.type == AR_FULL)
4803 else if (se->direct_byref)
4806 full = gfc_full_array_ref_p (info->ref);
4810 if (se->direct_byref)
4812 /* Copy the descriptor for pointer assignments. */
4813 gfc_add_modify (&se->pre, se->expr, desc);
4815 /* Add any offsets from subreferences. */
4816 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
4817 subref_array_target, expr);
4819 else if (se->want_pointer)
4821 /* We pass full arrays directly. This means that pointers and
4822 allocatable arrays should also work. */
4823 se->expr = build_fold_addr_expr (desc);
4830 if (expr->ts.type == BT_CHARACTER)
4831 se->string_length = gfc_get_expr_charlen (expr);
4838 /* A transformational function return value will be a temporary
4839 array descriptor. We still need to go through the scalarizer
4840 to create the descriptor. Elemental functions ar handled as
4841 arbitrary expressions, i.e. copy to a temporary. */
4843 /* Look for the SS for this function. */
4844 while (secss != gfc_ss_terminator
4845 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
4846 secss = secss->next;
4848 if (se->direct_byref)
4850 gcc_assert (secss != gfc_ss_terminator);
4852 /* For pointer assignments pass the descriptor directly. */
4854 se->expr = build_fold_addr_expr (se->expr);
4855 gfc_conv_expr (se, expr);
4859 if (secss == gfc_ss_terminator)
4861 /* Elemental function. */
4863 if (expr->ts.type == BT_CHARACTER
4864 && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
4865 get_elemental_fcn_charlen (expr, se);
4871 /* Transformational function. */
4872 info = &secss->data.info;
4878 /* Constant array constructors don't need a temporary. */
4879 if (ss->type == GFC_SS_CONSTRUCTOR
4880 && expr->ts.type != BT_CHARACTER
4881 && gfc_constant_array_constructor_p (expr->value.constructor))
4884 info = &ss->data.info;
4896 /* Something complicated. Copy it into a temporary. */
4903 gfc_init_loopinfo (&loop);
4905 /* Associate the SS with the loop. */
4906 gfc_add_ss_to_loop (&loop, ss);
4908 /* Tell the scalarizer not to bother creating loop variables, etc. */
4910 loop.array_parameter = 1;
4912 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4913 gcc_assert (!se->direct_byref);
4915 /* Setup the scalarizing loops and bounds. */
4916 gfc_conv_ss_startstride (&loop);
4920 /* Tell the scalarizer to make a temporary. */
4921 loop.temp_ss = gfc_get_ss ();
4922 loop.temp_ss->type = GFC_SS_TEMP;
4923 loop.temp_ss->next = gfc_ss_terminator;
4925 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
4926 gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
4928 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
4930 if (expr->ts.type == BT_CHARACTER)
4931 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4933 loop.temp_ss->string_length = NULL;
4935 se->string_length = loop.temp_ss->string_length;
4936 loop.temp_ss->data.temp.dimen = loop.dimen;
4937 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4940 gfc_conv_loop_setup (&loop, & expr->where);
4944 /* Copy into a temporary and pass that. We don't need to copy the data
4945 back because expressions and vector subscripts must be INTENT_IN. */
4946 /* TODO: Optimize passing function return values. */
4950 /* Start the copying loops. */
4951 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4952 gfc_mark_ss_chain_used (ss, 1);
4953 gfc_start_scalarized_body (&loop, &block);
4955 /* Copy each data element. */
4956 gfc_init_se (&lse, NULL);
4957 gfc_copy_loopinfo_to_se (&lse, &loop);
4958 gfc_init_se (&rse, NULL);
4959 gfc_copy_loopinfo_to_se (&rse, &loop);
4961 lse.ss = loop.temp_ss;
4964 gfc_conv_scalarized_array_ref (&lse, NULL);
4965 if (expr->ts.type == BT_CHARACTER)
4967 gfc_conv_expr (&rse, expr);
4968 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4969 rse.expr = build_fold_indirect_ref (rse.expr);
4972 gfc_conv_expr_val (&rse, expr);
4974 gfc_add_block_to_block (&block, &rse.pre);
4975 gfc_add_block_to_block (&block, &lse.pre);
4977 lse.string_length = rse.string_length;
4978 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
4979 expr->expr_type == EXPR_VARIABLE);
4980 gfc_add_expr_to_block (&block, tmp);
4982 /* Finish the copying loops. */
4983 gfc_trans_scalarizing_loops (&loop, &block);
4985 desc = loop.temp_ss->data.info.descriptor;
4987 gcc_assert (is_gimple_lvalue (desc));
4989 else if (expr->expr_type == EXPR_FUNCTION)
4991 desc = info->descriptor;
4992 se->string_length = ss->string_length;
4996 /* We pass sections without copying to a temporary. Make a new
4997 descriptor and point it at the section we want. The loop variable
4998 limits will be the limits of the section.
4999 A function may decide to repack the array to speed up access, but
5000 we're not bothered about that here. */
5009 /* Set the string_length for a character array. */
5010 if (expr->ts.type == BT_CHARACTER)
5011 se->string_length = gfc_get_expr_charlen (expr);
5013 desc = info->descriptor;
5014 gcc_assert (secss && secss != gfc_ss_terminator);
5015 if (se->direct_byref)
5017 /* For pointer assignments we fill in the destination. */
5019 parmtype = TREE_TYPE (parm);
5023 /* Otherwise make a new one. */
5024 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5025 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5026 loop.from, loop.to, 0,
5028 parm = gfc_create_var (parmtype, "parm");
5031 offset = gfc_index_zero_node;
5034 /* The following can be somewhat confusing. We have two
5035 descriptors, a new one and the original array.
5036 {parm, parmtype, dim} refer to the new one.
5037 {desc, type, n, secss, loop} refer to the original, which maybe
5038 a descriptorless array.
5039 The bounds of the scalarization are the bounds of the section.
5040 We don't have to worry about numeric overflows when calculating
5041 the offsets because all elements are within the array data. */
5043 /* Set the dtype. */
5044 tmp = gfc_conv_descriptor_dtype (parm);
5045 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5047 /* Set offset for assignments to pointer only to zero if it is not
5049 if (se->direct_byref
5050 && info->ref && info->ref->u.ar.type != AR_FULL)
5051 base = gfc_index_zero_node;
5052 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5053 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5057 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5058 for (n = 0; n < ndim; n++)
5060 stride = gfc_conv_array_stride (desc, n);
5062 /* Work out the offset. */
5064 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5066 gcc_assert (info->subscript[n]
5067 && info->subscript[n]->type == GFC_SS_SCALAR);
5068 start = info->subscript[n]->data.scalar.expr;
5072 /* Check we haven't somehow got out of sync. */
5073 gcc_assert (info->dim[dim] == n);
5075 /* Evaluate and remember the start of the section. */
5076 start = info->start[dim];
5077 stride = gfc_evaluate_now (stride, &loop.pre);
5080 tmp = gfc_conv_array_lbound (desc, n);
5081 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5083 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5084 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5087 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5089 /* For elemental dimensions, we only need the offset. */
5093 /* Vector subscripts need copying and are handled elsewhere. */
5095 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5097 /* Set the new lower bound. */
5098 from = loop.from[dim];
5101 /* If we have an array section or are assigning make sure that
5102 the lower bound is 1. References to the full
5103 array should otherwise keep the original bounds. */
5105 || info->ref->u.ar.type != AR_FULL)
5106 && !integer_onep (from))
5108 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5109 gfc_index_one_node, from);
5110 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5111 from = gfc_index_one_node;
5113 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
5114 gfc_add_modify (&loop.pre, tmp, from);
5116 /* Set the new upper bound. */
5117 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
5118 gfc_add_modify (&loop.pre, tmp, to);
5120 /* Multiply the stride by the section stride to get the
5122 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5123 stride, info->stride[dim]);
5125 if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
5127 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5130 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5132 tmp = gfc_conv_array_lbound (desc, n);
5133 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5134 tmp, loop.from[dim]);
5135 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5136 tmp, gfc_conv_array_stride (desc, n));
5137 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5141 /* Store the new stride. */
5142 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
5143 gfc_add_modify (&loop.pre, tmp, stride);
5148 if (se->data_not_needed)
5149 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
5151 /* Point the data pointer at the first element in the section. */
5152 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5153 subref_array_target, expr);
5155 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5156 && !se->data_not_needed)
5158 /* Set the offset. */
5159 tmp = gfc_conv_descriptor_offset (parm);
5160 gfc_add_modify (&loop.pre, tmp, base);
5164 /* Only the callee knows what the correct offset it, so just set
5166 tmp = gfc_conv_descriptor_offset (parm);
5167 gfc_add_modify (&loop.pre, tmp, gfc_index_zero_node);
5172 if (!se->direct_byref)
5174 /* Get a pointer to the new descriptor. */
5175 if (se->want_pointer)
5176 se->expr = build_fold_addr_expr (desc);
5181 gfc_add_block_to_block (&se->pre, &loop.pre);
5182 gfc_add_block_to_block (&se->post, &loop.post);
5184 /* Cleanup the scalarizer. */
5185 gfc_cleanup_loop (&loop);
5189 /* Convert an array for passing as an actual parameter. */
5190 /* TODO: Optimize passing g77 arrays. */
5193 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
5194 const gfc_symbol *fsym, const char *proc_name)
5198 tree tmp = NULL_TREE;
5200 tree parent = DECL_CONTEXT (current_function_decl);
5201 bool full_array_var, this_array_result;
5205 full_array_var = (expr->expr_type == EXPR_VARIABLE
5206 && expr->ref->u.ar.type == AR_FULL);
5207 sym = full_array_var ? expr->symtree->n.sym : NULL;
5209 /* The symbol should have an array specification. */
5210 gcc_assert (!sym || sym->as);
5212 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5214 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5215 expr->ts.cl->backend_decl = tmp;
5216 se->string_length = tmp;
5219 /* Is this the result of the enclosing procedure? */
5220 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5221 if (this_array_result
5222 && (sym->backend_decl != current_function_decl)
5223 && (sym->backend_decl != parent))
5224 this_array_result = false;
5226 /* Passing address of the array if it is not pointer or assumed-shape. */
5227 if (full_array_var && g77 && !this_array_result)
5229 tmp = gfc_get_symbol_decl (sym);
5231 if (sym->ts.type == BT_CHARACTER)
5232 se->string_length = sym->ts.cl->backend_decl;
5233 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
5234 && !sym->attr.allocatable)
5236 /* Some variables are declared directly, others are declared as
5237 pointers and allocated on the heap. */
5238 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5241 se->expr = build_fold_addr_expr (tmp);
5244 if (sym->attr.allocatable)
5246 if (sym->attr.dummy || sym->attr.result)
5248 gfc_conv_expr_descriptor (se, expr, ss);
5249 se->expr = gfc_conv_array_data (se->expr);
5252 se->expr = gfc_conv_array_data (tmp);
5257 if (this_array_result)
5259 /* Result of the enclosing function. */
5260 gfc_conv_expr_descriptor (se, expr, ss);
5261 se->expr = build_fold_addr_expr (se->expr);
5263 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5264 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5265 se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
5271 /* Every other type of array. */
5272 se->want_pointer = 1;
5273 gfc_conv_expr_descriptor (se, expr, ss);
5277 /* Deallocate the allocatable components of structures that are
5279 if (expr->ts.type == BT_DERIVED
5280 && expr->ts.derived->attr.alloc_comp
5281 && expr->expr_type != EXPR_VARIABLE)
5283 tmp = build_fold_indirect_ref (se->expr);
5284 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
5285 gfc_add_expr_to_block (&se->post, tmp);
5291 /* Repack the array. */
5293 if (gfc_option.warn_array_temp)
5296 gfc_warning ("Creating array temporary at %L for argument '%s'",
5297 &expr->where, fsym->name);
5299 gfc_warning ("Creating array temporary at %L", &expr->where);
5302 ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
5304 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5306 tmp = gfc_conv_expr_present (sym);
5307 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5308 fold_convert (TREE_TYPE (se->expr), ptr),
5309 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5312 ptr = gfc_evaluate_now (ptr, &se->pre);
5316 if (gfc_option.flag_check_array_temporaries)
5320 if (fsym && proc_name)
5321 asprintf (&msg, "An array temporary was created for argument "
5322 "'%s' of procedure '%s'", fsym->name, proc_name);
5324 asprintf (&msg, "An array temporary was created");
5326 tmp = build_fold_indirect_ref (desc);
5327 tmp = gfc_conv_array_data (tmp);
5328 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5329 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5331 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5332 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5333 gfc_conv_expr_present (sym), tmp);
5335 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5340 gfc_start_block (&block);
5342 /* Copy the data back. */
5343 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5345 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
5346 gfc_add_expr_to_block (&block, tmp);
5349 /* Free the temporary. */
5350 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5351 gfc_add_expr_to_block (&block, tmp);
5353 stmt = gfc_finish_block (&block);
5355 gfc_init_block (&block);
5356 /* Only if it was repacked. This code needs to be executed before the
5357 loop cleanup code. */
5358 tmp = build_fold_indirect_ref (desc);
5359 tmp = gfc_conv_array_data (tmp);
5360 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5361 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5363 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5364 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5365 gfc_conv_expr_present (sym), tmp);
5367 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
5369 gfc_add_expr_to_block (&block, tmp);
5370 gfc_add_block_to_block (&block, &se->post);
5372 gfc_init_block (&se->post);
5373 gfc_add_block_to_block (&se->post, &block);
5378 /* Generate code to deallocate an array, if it is allocated. */
5381 gfc_trans_dealloc_allocated (tree descriptor)
5387 gfc_start_block (&block);
5389 var = gfc_conv_descriptor_data_get (descriptor);
5392 /* Call array_deallocate with an int * present in the second argument.
5393 Although it is ignored here, it's presence ensures that arrays that
5394 are already deallocated are ignored. */
5395 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5396 gfc_add_expr_to_block (&block, tmp);
5398 /* Zero the data pointer. */
5399 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5400 var, build_int_cst (TREE_TYPE (var), 0));
5401 gfc_add_expr_to_block (&block, tmp);
5403 return gfc_finish_block (&block);
5407 /* This helper function calculates the size in words of a full array. */
5410 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5415 idx = gfc_rank_cst[rank - 1];
5416 nelems = gfc_conv_descriptor_ubound (decl, idx);
5417 tmp = gfc_conv_descriptor_lbound (decl, idx);
5418 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5419 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5420 tmp, gfc_index_one_node);
5421 tmp = gfc_evaluate_now (tmp, block);
5423 nelems = gfc_conv_descriptor_stride (decl, idx);
5424 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5425 return gfc_evaluate_now (tmp, block);
5429 /* Allocate dest to the same size as src, and copy src -> dest. */
5432 gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
5441 /* If the source is null, set the destination to null. */
5442 gfc_init_block (&block);
5443 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5444 null_data = gfc_finish_block (&block);
5446 gfc_init_block (&block);
5448 nelems = get_full_array_size (&block, src, rank);
5449 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
5450 fold_convert (gfc_array_index_type,
5451 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
5453 /* Allocate memory to the destination. */
5454 tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
5456 gfc_conv_descriptor_data_set (&block, dest, tmp);
5458 /* We know the temporary and the value will be the same length,
5459 so can use memcpy. */
5460 tmp = built_in_decls[BUILT_IN_MEMCPY];
5461 tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
5462 gfc_conv_descriptor_data_get (src), size);
5463 gfc_add_expr_to_block (&block, tmp);
5464 tmp = gfc_finish_block (&block);
5466 /* Null the destination if the source is null; otherwise do
5467 the allocate and copy. */
5468 null_cond = gfc_conv_descriptor_data_get (src);
5469 null_cond = convert (pvoid_type_node, null_cond);
5470 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5471 null_cond, null_pointer_node);
5472 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5476 /* Recursively traverse an object of derived type, generating code to
5477 deallocate, nullify or copy allocatable components. This is the work horse
5478 function for the functions named in this enum. */
5480 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
5483 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5484 tree dest, int rank, int purpose)
5488 stmtblock_t fnblock;
5489 stmtblock_t loopbody;
5499 tree null_cond = NULL_TREE;
5501 gfc_init_block (&fnblock);
5503 if (POINTER_TYPE_P (TREE_TYPE (decl)))
5504 decl = build_fold_indirect_ref (decl);
5506 /* If this an array of derived types with allocatable components
5507 build a loop and recursively call this function. */
5508 if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
5509 || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5511 tmp = gfc_conv_array_data (decl);
5512 var = build_fold_indirect_ref (tmp);
5514 /* Get the number of elements - 1 and set the counter. */
5515 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
5517 /* Use the descriptor for an allocatable array. Since this
5518 is a full array reference, we only need the descriptor
5519 information from dimension = rank. */
5520 tmp = get_full_array_size (&fnblock, decl, rank);
5521 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5522 tmp, gfc_index_one_node);
5524 null_cond = gfc_conv_descriptor_data_get (decl);
5525 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5526 build_int_cst (TREE_TYPE (null_cond), 0));
5530 /* Otherwise use the TYPE_DOMAIN information. */
5531 tmp = array_type_nelts (TREE_TYPE (decl));
5532 tmp = fold_convert (gfc_array_index_type, tmp);
5535 /* Remember that this is, in fact, the no. of elements - 1. */
5536 nelems = gfc_evaluate_now (tmp, &fnblock);
5537 index = gfc_create_var (gfc_array_index_type, "S");
5539 /* Build the body of the loop. */
5540 gfc_init_block (&loopbody);
5542 vref = gfc_build_array_ref (var, index, NULL);
5544 if (purpose == COPY_ALLOC_COMP)
5546 tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
5547 gfc_add_expr_to_block (&fnblock, tmp);
5549 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
5550 dref = gfc_build_array_ref (tmp, index, NULL);
5551 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
5554 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
5556 gfc_add_expr_to_block (&loopbody, tmp);
5558 /* Build the loop and return. */
5559 gfc_init_loopinfo (&loop);
5561 loop.from[0] = gfc_index_zero_node;
5562 loop.loopvar[0] = index;
5563 loop.to[0] = nelems;
5564 gfc_trans_scalarizing_loops (&loop, &loopbody);
5565 gfc_add_block_to_block (&fnblock, &loop.pre);
5567 tmp = gfc_finish_block (&fnblock);
5568 if (null_cond != NULL_TREE)
5569 tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
5574 /* Otherwise, act on the components or recursively call self to
5575 act on a chain of components. */
5576 for (c = der_type->components; c; c = c->next)
5578 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
5579 && c->ts.derived->attr.alloc_comp;
5580 cdecl = c->backend_decl;
5581 ctype = TREE_TYPE (cdecl);
5585 case DEALLOCATE_ALLOC_COMP:
5586 /* Do not deallocate the components of ultimate pointer
5588 if (cmp_has_alloc_comps && !c->attr.pointer)
5590 comp = fold_build3 (COMPONENT_REF, ctype,
5591 decl, cdecl, NULL_TREE);
5592 rank = c->as ? c->as->rank : 0;
5593 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5595 gfc_add_expr_to_block (&fnblock, tmp);
5598 if (c->attr.allocatable)
5600 comp = fold_build3 (COMPONENT_REF, ctype,
5601 decl, cdecl, NULL_TREE);
5602 tmp = gfc_trans_dealloc_allocated (comp);
5603 gfc_add_expr_to_block (&fnblock, tmp);
5607 case NULLIFY_ALLOC_COMP:
5608 if (c->attr.pointer)
5610 else if (c->attr.allocatable)
5612 comp = fold_build3 (COMPONENT_REF, ctype,
5613 decl, cdecl, NULL_TREE);
5614 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
5616 else if (cmp_has_alloc_comps)
5618 comp = fold_build3 (COMPONENT_REF, ctype,
5619 decl, cdecl, NULL_TREE);
5620 rank = c->as ? c->as->rank : 0;
5621 tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
5623 gfc_add_expr_to_block (&fnblock, tmp);
5627 case COPY_ALLOC_COMP:
5628 if (c->attr.pointer)
5631 /* We need source and destination components. */
5632 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
5633 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
5634 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
5636 if (c->attr.allocatable && !cmp_has_alloc_comps)
5638 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
5639 gfc_add_expr_to_block (&fnblock, tmp);
5642 if (cmp_has_alloc_comps)
5644 rank = c->as ? c->as->rank : 0;
5645 tmp = fold_convert (TREE_TYPE (dcmp), comp);
5646 gfc_add_modify (&fnblock, dcmp, tmp);
5647 tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
5649 gfc_add_expr_to_block (&fnblock, tmp);
5659 return gfc_finish_block (&fnblock);
5662 /* Recursively traverse an object of derived type, generating code to
5663 nullify allocatable components. */
5666 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5668 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5669 NULLIFY_ALLOC_COMP);
5673 /* Recursively traverse an object of derived type, generating code to
5674 deallocate allocatable components. */
5677 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
5679 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
5680 DEALLOCATE_ALLOC_COMP);
5684 /* Recursively traverse an object of derived type, generating code to
5685 copy its allocatable components. */
5688 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
5690 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
5694 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
5695 Do likewise, recursively if necessary, with the allocatable components of
5699 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
5704 stmtblock_t fnblock;
5707 bool sym_has_alloc_comp;
5709 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
5710 && sym->ts.derived->attr.alloc_comp;
5712 /* Make sure the frontend gets these right. */
5713 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
5714 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
5715 "allocatable attribute or derived type without allocatable "
5718 gfc_init_block (&fnblock);
5720 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
5721 || TREE_CODE (sym->backend_decl) == PARM_DECL);
5723 if (sym->ts.type == BT_CHARACTER
5724 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
5726 gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
5727 gfc_trans_vla_type_sizes (sym, &fnblock);
5730 /* Dummy and use associated variables don't need anything special. */
5731 if (sym->attr.dummy || sym->attr.use_assoc)
5733 gfc_add_expr_to_block (&fnblock, body);
5735 return gfc_finish_block (&fnblock);
5738 gfc_get_backend_locus (&loc);
5739 gfc_set_backend_locus (&sym->declared_at);
5740 descriptor = sym->backend_decl;
5742 /* Although static, derived types with default initializers and
5743 allocatable components must not be nulled wholesale; instead they
5744 are treated component by component. */
5745 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
5747 /* SAVEd variables are not freed on exit. */
5748 gfc_trans_static_array_pointer (sym);
5752 /* Get the descriptor type. */
5753 type = TREE_TYPE (sym->backend_decl);
5755 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
5757 if (!sym->attr.save)
5759 rank = sym->as ? sym->as->rank : 0;
5760 tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
5761 gfc_add_expr_to_block (&fnblock, tmp);
5764 tmp = gfc_init_default_dt (sym, NULL);
5765 gfc_add_expr_to_block (&fnblock, tmp);
5769 else if (!GFC_DESCRIPTOR_TYPE_P (type))
5771 /* If the backend_decl is not a descriptor, we must have a pointer
5773 descriptor = build_fold_indirect_ref (sym->backend_decl);
5774 type = TREE_TYPE (descriptor);
5777 /* NULLIFY the data pointer. */
5778 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
5779 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
5781 gfc_add_expr_to_block (&fnblock, body);
5783 gfc_set_backend_locus (&loc);
5785 /* Allocatable arrays need to be freed when they go out of scope.
5786 The allocatable components of pointers must not be touched. */
5787 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
5788 && !sym->attr.pointer && !sym->attr.save)
5791 rank = sym->as ? sym->as->rank : 0;
5792 tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
5793 gfc_add_expr_to_block (&fnblock, tmp);
5796 if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
5798 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
5799 gfc_add_expr_to_block (&fnblock, tmp);
5802 return gfc_finish_block (&fnblock);
5805 /************ Expression Walking Functions ******************/
5807 /* Walk a variable reference.
5809 Possible extension - multiple component subscripts.
5810 x(:,:) = foo%a(:)%b(:)
5812 forall (i=..., j=...)
5813 x(i,j) = foo%a(j)%b(i)
5815 This adds a fair amount of complexity because you need to deal with more
5816 than one ref. Maybe handle in a similar manner to vector subscripts.
5817 Maybe not worth the effort. */
5821 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
5829 for (ref = expr->ref; ref; ref = ref->next)
5830 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
5833 for (; ref; ref = ref->next)
5835 if (ref->type == REF_SUBSTRING)
5837 newss = gfc_get_ss ();
5838 newss->type = GFC_SS_SCALAR;
5839 newss->expr = ref->u.ss.start;
5843 newss = gfc_get_ss ();
5844 newss->type = GFC_SS_SCALAR;
5845 newss->expr = ref->u.ss.end;
5850 /* We're only interested in array sections from now on. */
5851 if (ref->type != REF_ARRAY)
5858 for (n = 0; n < ar->dimen; n++)
5860 newss = gfc_get_ss ();
5861 newss->type = GFC_SS_SCALAR;
5862 newss->expr = ar->start[n];
5869 newss = gfc_get_ss ();
5870 newss->type = GFC_SS_SECTION;
5873 newss->data.info.dimen = ar->as->rank;
5874 newss->data.info.ref = ref;
5876 /* Make sure array is the same as array(:,:), this way
5877 we don't need to special case all the time. */
5878 ar->dimen = ar->as->rank;
5879 for (n = 0; n < ar->dimen; n++)
5881 newss->data.info.dim[n] = n;
5882 ar->dimen_type[n] = DIMEN_RANGE;
5884 gcc_assert (ar->start[n] == NULL);
5885 gcc_assert (ar->end[n] == NULL);
5886 gcc_assert (ar->stride[n] == NULL);
5892 newss = gfc_get_ss ();
5893 newss->type = GFC_SS_SECTION;
5896 newss->data.info.dimen = 0;
5897 newss->data.info.ref = ref;
5901 /* We add SS chains for all the subscripts in the section. */
5902 for (n = 0; n < ar->dimen; n++)
5906 switch (ar->dimen_type[n])
5909 /* Add SS for elemental (scalar) subscripts. */
5910 gcc_assert (ar->start[n]);
5911 indexss = gfc_get_ss ();
5912 indexss->type = GFC_SS_SCALAR;
5913 indexss->expr = ar->start[n];
5914 indexss->next = gfc_ss_terminator;
5915 indexss->loop_chain = gfc_ss_terminator;
5916 newss->data.info.subscript[n] = indexss;
5920 /* We don't add anything for sections, just remember this
5921 dimension for later. */
5922 newss->data.info.dim[newss->data.info.dimen] = n;
5923 newss->data.info.dimen++;
5927 /* Create a GFC_SS_VECTOR index in which we can store
5928 the vector's descriptor. */
5929 indexss = gfc_get_ss ();
5930 indexss->type = GFC_SS_VECTOR;
5931 indexss->expr = ar->start[n];
5932 indexss->next = gfc_ss_terminator;
5933 indexss->loop_chain = gfc_ss_terminator;
5934 newss->data.info.subscript[n] = indexss;
5935 newss->data.info.dim[newss->data.info.dimen] = n;
5936 newss->data.info.dimen++;
5940 /* We should know what sort of section it is by now. */
5944 /* We should have at least one non-elemental dimension. */
5945 gcc_assert (newss->data.info.dimen > 0);
5950 /* We should know what sort of section it is by now. */
5959 /* Walk an expression operator. If only one operand of a binary expression is
5960 scalar, we must also add the scalar term to the SS chain. */
5963 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
5969 head = gfc_walk_subexpr (ss, expr->value.op.op1);
5970 if (expr->value.op.op2 == NULL)
5973 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
5975 /* All operands are scalar. Pass back and let the caller deal with it. */
5979 /* All operands require scalarization. */
5980 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
5983 /* One of the operands needs scalarization, the other is scalar.
5984 Create a gfc_ss for the scalar expression. */
5985 newss = gfc_get_ss ();
5986 newss->type = GFC_SS_SCALAR;
5989 /* First operand is scalar. We build the chain in reverse order, so
5990 add the scalar SS after the second operand. */
5992 while (head && head->next != ss)
5994 /* Check we haven't somehow broken the chain. */
5998 newss->expr = expr->value.op.op1;
6000 else /* head2 == head */
6002 gcc_assert (head2 == head);
6003 /* Second operand is scalar. */
6004 newss->next = head2;
6006 newss->expr = expr->value.op.op2;
6013 /* Reverse a SS chain. */
6016 gfc_reverse_ss (gfc_ss * ss)
6021 gcc_assert (ss != NULL);
6023 head = gfc_ss_terminator;
6024 while (ss != gfc_ss_terminator)
6027 /* Check we didn't somehow break the chain. */
6028 gcc_assert (next != NULL);
6038 /* Walk the arguments of an elemental function. */
6041 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6049 head = gfc_ss_terminator;
6052 for (; arg; arg = arg->next)
6057 newss = gfc_walk_subexpr (head, arg->expr);
6060 /* Scalar argument. */
6061 newss = gfc_get_ss ();
6063 newss->expr = arg->expr;
6073 while (tail->next != gfc_ss_terminator)
6080 /* If all the arguments are scalar we don't need the argument SS. */
6081 gfc_free_ss_chain (head);
6086 /* Add it onto the existing chain. */
6092 /* Walk a function call. Scalar functions are passed back, and taken out of
6093 scalarization loops. For elemental functions we walk their arguments.
6094 The result of functions returning arrays is stored in a temporary outside
6095 the loop, so that the function is only called once. Hence we do not need
6096 to walk their arguments. */
6099 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6102 gfc_intrinsic_sym *isym;
6105 isym = expr->value.function.isym;
6107 /* Handle intrinsic functions separately. */
6109 return gfc_walk_intrinsic_function (ss, expr, isym);
6111 sym = expr->value.function.esym;
6113 sym = expr->symtree->n.sym;
6115 /* A function that returns arrays. */
6116 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
6118 newss = gfc_get_ss ();
6119 newss->type = GFC_SS_FUNCTION;
6122 newss->data.info.dimen = expr->rank;
6126 /* Walk the parameters of an elemental function. For now we always pass
6128 if (sym->attr.elemental)
6129 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6132 /* Scalar functions are OK as these are evaluated outside the scalarization
6133 loop. Pass back and let the caller deal with it. */
6138 /* An array temporary is constructed for array constructors. */
6141 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6146 newss = gfc_get_ss ();
6147 newss->type = GFC_SS_CONSTRUCTOR;
6150 newss->data.info.dimen = expr->rank;
6151 for (n = 0; n < expr->rank; n++)
6152 newss->data.info.dim[n] = n;
6158 /* Walk an expression. Add walked expressions to the head of the SS chain.
6159 A wholly scalar expression will not be added. */
6162 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6166 switch (expr->expr_type)
6169 head = gfc_walk_variable_expr (ss, expr);
6173 head = gfc_walk_op_expr (ss, expr);
6177 head = gfc_walk_function_expr (ss, expr);
6182 case EXPR_STRUCTURE:
6183 /* Pass back and let the caller deal with it. */
6187 head = gfc_walk_array_constructor (ss, expr);
6190 case EXPR_SUBSTRING:
6191 /* Pass back and let the caller deal with it. */
6195 internal_error ("bad expression type during walk (%d)",
6202 /* Entry point for expression walking.
6203 A return value equal to the passed chain means this is
6204 a scalar expression. It is up to the caller to take whatever action is
6205 necessary to translate these. */
6208 gfc_walk_expr (gfc_expr * expr)
6212 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6213 return gfc_reverse_ss (res);