1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
86 #include "constructor.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
95 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
97 /* The contents of this structure aren't actually used, just the address. */
98 static gfc_ss gfc_ss_terminator_var;
99 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
103 gfc_array_dataptr_type (tree desc)
105 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
109 /* Build expressions to access the members of an array descriptor.
110 It's surprisingly easy to mess up here, so never access
111 an array descriptor by "brute force", always use these
112 functions. This also avoids problems if we change the format
113 of an array descriptor.
115 To understand these magic numbers, look at the comments
116 before gfc_build_array_type() in trans-types.c.
118 The code within these defines should be the only code which knows the format
119 of an array descriptor.
121 Any code just needing to read obtain the bounds of an array should use
122 gfc_conv_array_* rather than the following functions as these will return
123 know constant values, and work with arrays which do not have descriptors.
125 Don't forget to #undef these! */
128 #define OFFSET_FIELD 1
129 #define DTYPE_FIELD 2
130 #define DIMENSION_FIELD 3
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
140 gfc_conv_descriptor_data_get (tree desc)
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
150 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
151 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
156 /* This provides WRITE access to the data field.
158 TUPLES_P is true if we are generating tuples.
160 This function gets called through the following macros:
161 gfc_conv_descriptor_data_set
162 gfc_conv_descriptor_data_set. */
165 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 type = TREE_TYPE (desc);
170 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172 field = TYPE_FIELDS (type);
173 gcc_assert (DATA_FIELD == 0);
175 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
176 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
180 /* This provides address access to the data field. This should only be
181 used by array allocation, passing this on to the runtime. */
184 gfc_conv_descriptor_data_addr (tree desc)
188 type = TREE_TYPE (desc);
189 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
191 field = TYPE_FIELDS (type);
192 gcc_assert (DATA_FIELD == 0);
194 t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
195 return gfc_build_addr_expr (NULL_TREE, t);
199 gfc_conv_descriptor_offset (tree desc)
204 type = TREE_TYPE (desc);
205 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
207 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
208 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
210 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
211 desc, field, NULL_TREE);
215 gfc_conv_descriptor_offset_get (tree desc)
217 return gfc_conv_descriptor_offset (desc);
221 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
224 tree t = gfc_conv_descriptor_offset (desc);
225 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
230 gfc_conv_descriptor_dtype (tree desc)
235 type = TREE_TYPE (desc);
236 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
238 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
239 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
241 return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
242 desc, field, NULL_TREE);
246 gfc_conv_descriptor_dimension (tree desc, tree dim)
252 type = TREE_TYPE (desc);
253 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
255 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
256 gcc_assert (field != NULL_TREE
257 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
258 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
260 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
261 desc, field, NULL_TREE);
262 tmp = gfc_build_array_ref (tmp, dim, NULL);
267 gfc_conv_descriptor_stride (tree desc, tree dim)
272 tmp = gfc_conv_descriptor_dimension (desc, dim);
273 field = TYPE_FIELDS (TREE_TYPE (tmp));
274 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
275 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
277 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
278 tmp, field, NULL_TREE);
283 gfc_conv_descriptor_stride_get (tree desc, tree dim)
285 tree type = TREE_TYPE (desc);
286 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
287 if (integer_zerop (dim)
288 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
289 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
290 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
291 return gfc_index_one_node;
293 return gfc_conv_descriptor_stride (desc, dim);
297 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
298 tree dim, tree value)
300 tree t = gfc_conv_descriptor_stride (desc, dim);
301 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
305 gfc_conv_descriptor_lbound (tree desc, tree dim)
310 tmp = gfc_conv_descriptor_dimension (desc, dim);
311 field = TYPE_FIELDS (TREE_TYPE (tmp));
312 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
313 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
315 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
316 tmp, field, NULL_TREE);
321 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
323 return gfc_conv_descriptor_lbound (desc, dim);
327 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
328 tree dim, tree value)
330 tree t = gfc_conv_descriptor_lbound (desc, dim);
331 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
335 gfc_conv_descriptor_ubound (tree desc, tree dim)
340 tmp = gfc_conv_descriptor_dimension (desc, dim);
341 field = TYPE_FIELDS (TREE_TYPE (tmp));
342 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
343 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
345 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
346 tmp, field, NULL_TREE);
351 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
353 return gfc_conv_descriptor_ubound (desc, dim);
357 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
358 tree dim, tree value)
360 tree t = gfc_conv_descriptor_ubound (desc, dim);
361 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
364 /* Build a null array descriptor constructor. */
367 gfc_build_null_descriptor (tree type)
372 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
373 gcc_assert (DATA_FIELD == 0);
374 field = TYPE_FIELDS (type);
376 /* Set a NULL data pointer. */
377 tmp = build_constructor_single (type, field, null_pointer_node);
378 TREE_CONSTANT (tmp) = 1;
379 /* All other fields are ignored. */
385 /* Cleanup those #defines. */
390 #undef DIMENSION_FIELD
391 #undef STRIDE_SUBFIELD
392 #undef LBOUND_SUBFIELD
393 #undef UBOUND_SUBFIELD
396 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
397 flags & 1 = Main loop body.
398 flags & 2 = temp copy loop. */
401 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
403 for (; ss != gfc_ss_terminator; ss = ss->next)
404 ss->useflags = flags;
407 static void gfc_free_ss (gfc_ss *);
410 /* Free a gfc_ss chain. */
413 gfc_free_ss_chain (gfc_ss * ss)
417 while (ss != gfc_ss_terminator)
419 gcc_assert (ss != NULL);
430 gfc_free_ss (gfc_ss * ss)
437 for (n = 0; n < ss->data.info.dimen; n++)
439 if (ss->data.info.subscript[ss->data.info.dim[n]])
440 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
452 /* Free all the SS associated with a loop. */
455 gfc_cleanup_loop (gfc_loopinfo * loop)
461 while (ss != gfc_ss_terminator)
463 gcc_assert (ss != NULL);
464 next = ss->loop_chain;
471 /* Associate a SS chain with a loop. */
474 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
478 if (head == gfc_ss_terminator)
482 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
484 if (ss->next == gfc_ss_terminator)
485 ss->loop_chain = loop->ss;
487 ss->loop_chain = ss->next;
489 gcc_assert (ss == gfc_ss_terminator);
494 /* Generate an initializer for a static pointer or allocatable array. */
497 gfc_trans_static_array_pointer (gfc_symbol * sym)
501 gcc_assert (TREE_STATIC (sym->backend_decl));
502 /* Just zero the data member. */
503 type = TREE_TYPE (sym->backend_decl);
504 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
508 /* If the bounds of SE's loop have not yet been set, see if they can be
509 determined from array spec AS, which is the array spec of a called
510 function. MAPPING maps the callee's dummy arguments to the values
511 that the caller is passing. Add any initialization and finalization
515 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
516 gfc_se * se, gfc_array_spec * as)
524 if (as && as->type == AS_EXPLICIT)
525 for (dim = 0; dim < se->loop->dimen; dim++)
527 n = se->loop->order[dim];
528 if (se->loop->to[n] == NULL_TREE)
530 /* Evaluate the lower bound. */
531 gfc_init_se (&tmpse, NULL);
532 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
533 gfc_add_block_to_block (&se->pre, &tmpse.pre);
534 gfc_add_block_to_block (&se->post, &tmpse.post);
535 lower = fold_convert (gfc_array_index_type, tmpse.expr);
537 /* ...and the upper bound. */
538 gfc_init_se (&tmpse, NULL);
539 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
540 gfc_add_block_to_block (&se->pre, &tmpse.pre);
541 gfc_add_block_to_block (&se->post, &tmpse.post);
542 upper = fold_convert (gfc_array_index_type, tmpse.expr);
544 /* Set the upper bound of the loop to UPPER - LOWER. */
545 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
546 tmp = gfc_evaluate_now (tmp, &se->pre);
547 se->loop->to[n] = tmp;
553 /* Generate code to allocate an array temporary, or create a variable to
554 hold the data. If size is NULL, zero the descriptor so that the
555 callee will allocate the array. If DEALLOC is true, also generate code to
556 free the array afterwards.
558 If INITIAL is not NULL, it is packed using internal_pack and the result used
559 as data instead of allocating a fresh, unitialized area of memory.
561 Initialization code is added to PRE and finalization code to POST.
562 DYNAMIC is true if the caller may want to extend the array later
563 using realloc. This prevents us from putting the array on the stack. */
566 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
567 gfc_ss_info * info, tree size, tree nelem,
568 tree initial, bool dynamic, bool dealloc)
574 desc = info->descriptor;
575 info->offset = gfc_index_zero_node;
576 if (size == NULL_TREE || integer_zerop (size))
578 /* A callee allocated array. */
579 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
584 /* Allocate the temporary. */
585 onstack = !dynamic && initial == NULL_TREE
586 && gfc_can_put_var_on_stack (size);
590 /* Make a temporary variable to hold the data. */
591 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
593 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
595 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
597 tmp = gfc_create_var (tmp, "A");
598 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
599 gfc_conv_descriptor_data_set (pre, desc, tmp);
603 /* Allocate memory to hold the data or call internal_pack. */
604 if (initial == NULL_TREE)
606 tmp = gfc_call_malloc (pre, NULL, size);
607 tmp = gfc_evaluate_now (tmp, pre);
614 stmtblock_t do_copying;
616 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
617 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
618 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
619 tmp = gfc_get_element_type (tmp);
620 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
621 packed = gfc_create_var (build_pointer_type (tmp), "data");
623 tmp = build_call_expr_loc (input_location,
624 gfor_fndecl_in_pack, 1, initial);
625 tmp = fold_convert (TREE_TYPE (packed), tmp);
626 gfc_add_modify (pre, packed, tmp);
628 tmp = build_fold_indirect_ref_loc (input_location,
630 source_data = gfc_conv_descriptor_data_get (tmp);
632 /* internal_pack may return source->data without any allocation
633 or copying if it is already packed. If that's the case, we
634 need to allocate and copy manually. */
636 gfc_start_block (&do_copying);
637 tmp = gfc_call_malloc (&do_copying, NULL, size);
638 tmp = fold_convert (TREE_TYPE (packed), tmp);
639 gfc_add_modify (&do_copying, packed, tmp);
640 tmp = gfc_build_memcpy_call (packed, source_data, size);
641 gfc_add_expr_to_block (&do_copying, tmp);
643 was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
644 packed, source_data);
645 tmp = gfc_finish_block (&do_copying);
646 tmp = build3_v (COND_EXPR, was_packed, tmp,
647 build_empty_stmt (input_location));
648 gfc_add_expr_to_block (pre, tmp);
650 tmp = fold_convert (pvoid_type_node, packed);
653 gfc_conv_descriptor_data_set (pre, desc, tmp);
656 info->data = gfc_conv_descriptor_data_get (desc);
658 /* The offset is zero because we create temporaries with a zero
660 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
662 if (dealloc && !onstack)
664 /* Free the temporary. */
665 tmp = gfc_conv_descriptor_data_get (desc);
666 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
667 gfc_add_expr_to_block (post, tmp);
672 /* Generate code to create and initialize the descriptor for a temporary
673 array. This is used for both temporaries needed by the scalarizer, and
674 functions returning arrays. Adjusts the loop variables to be
675 zero-based, and calculates the loop bounds for callee allocated arrays.
676 Allocate the array unless it's callee allocated (we have a callee
677 allocated array if 'callee_alloc' is true, or if loop->to[n] is
678 NULL_TREE for any n). Also fills in the descriptor, data and offset
679 fields of info if known. Returns the size of the array, or NULL for a
680 callee allocated array.
682 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
683 gfc_trans_allocate_array_storage.
687 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
688 gfc_loopinfo * loop, gfc_ss_info * info,
689 tree eltype, tree initial, bool dynamic,
690 bool dealloc, bool callee_alloc, locus * where)
702 gcc_assert (info->dimen > 0);
704 if (gfc_option.warn_array_temp && where)
705 gfc_warning ("Creating array temporary at %L", where);
707 /* Set the lower bound to zero. */
708 for (dim = 0; dim < info->dimen; dim++)
710 n = loop->order[dim];
711 /* Callee allocated arrays may not have a known bound yet. */
713 loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
714 gfc_array_index_type,
715 loop->to[n], loop->from[n]), pre);
716 loop->from[n] = gfc_index_zero_node;
718 info->delta[dim] = gfc_index_zero_node;
719 info->start[dim] = gfc_index_zero_node;
720 info->end[dim] = gfc_index_zero_node;
721 info->stride[dim] = gfc_index_one_node;
722 info->dim[dim] = dim;
725 /* Initialize the descriptor. */
727 gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
728 GFC_ARRAY_UNKNOWN, true);
729 desc = gfc_create_var (type, "atmp");
730 GFC_DECL_PACKED_ARRAY (desc) = 1;
732 info->descriptor = desc;
733 size = gfc_index_one_node;
735 /* Fill in the array dtype. */
736 tmp = gfc_conv_descriptor_dtype (desc);
737 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
740 Fill in the bounds and stride. This is a packed array, so:
743 for (n = 0; n < rank; n++)
746 delta = ubound[n] + 1 - lbound[n];
749 size = size * sizeof(element);
754 /* If there is at least one null loop->to[n], it is a callee allocated
756 for (n = 0; n < info->dimen; n++)
757 if (loop->to[n] == NULL_TREE)
763 for (n = 0; n < info->dimen; n++)
767 if (size == NULL_TREE)
769 /* For a callee allocated array express the loop bounds in terms
770 of the descriptor fields. */
772 MINUS_EXPR, gfc_array_index_type,
773 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
774 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
779 /* Store the stride and bound components in the descriptor. */
780 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[dim], size);
782 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[dim],
783 gfc_index_zero_node);
785 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[dim],
788 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
789 loop->to[n], gfc_index_one_node);
791 /* Check whether the size for this dimension is negative. */
792 cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
793 gfc_index_zero_node);
794 cond = gfc_evaluate_now (cond, pre);
799 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
801 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
802 size = gfc_evaluate_now (size, pre);
805 /* Get the size of the array. */
807 if (size && !callee_alloc)
809 /* If or_expr is true, then the extent in at least one
810 dimension is zero and the size is set to zero. */
811 size = fold_build3 (COND_EXPR, gfc_array_index_type,
812 or_expr, gfc_index_zero_node, size);
815 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
816 fold_convert (gfc_array_index_type,
817 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
825 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
828 if (info->dimen > loop->temp_dim)
829 loop->temp_dim = info->dimen;
835 /* Generate code to transpose array EXPR by creating a new descriptor
836 in which the dimension specifications have been reversed. */
839 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
841 tree dest, src, dest_index, src_index;
843 gfc_ss_info *dest_info;
844 gfc_ss *dest_ss, *src_ss;
850 src_ss = gfc_walk_expr (expr);
853 dest_info = &dest_ss->data.info;
854 gcc_assert (dest_info->dimen == 2);
856 /* Get a descriptor for EXPR. */
857 gfc_init_se (&src_se, NULL);
858 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
859 gfc_add_block_to_block (&se->pre, &src_se.pre);
860 gfc_add_block_to_block (&se->post, &src_se.post);
863 /* Allocate a new descriptor for the return value. */
864 dest = gfc_create_var (TREE_TYPE (src), "atmp");
865 dest_info->descriptor = dest;
868 /* Copy across the dtype field. */
869 gfc_add_modify (&se->pre,
870 gfc_conv_descriptor_dtype (dest),
871 gfc_conv_descriptor_dtype (src));
873 /* Copy the dimension information, renumbering dimension 1 to 0 and
875 for (n = 0; n < 2; n++)
877 dest_info->delta[n] = gfc_index_zero_node;
878 dest_info->start[n] = gfc_index_zero_node;
879 dest_info->end[n] = gfc_index_zero_node;
880 dest_info->stride[n] = gfc_index_one_node;
881 dest_info->dim[n] = n;
883 dest_index = gfc_rank_cst[n];
884 src_index = gfc_rank_cst[1 - n];
886 gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
887 gfc_conv_descriptor_stride_get (src, src_index));
889 gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
890 gfc_conv_descriptor_lbound_get (src, src_index));
892 gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
893 gfc_conv_descriptor_ubound_get (src, src_index));
897 gcc_assert (integer_zerop (loop->from[n]));
899 fold_build2 (MINUS_EXPR, gfc_array_index_type,
900 gfc_conv_descriptor_ubound_get (dest, dest_index),
901 gfc_conv_descriptor_lbound_get (dest, dest_index));
905 /* Copy the data pointer. */
906 dest_info->data = gfc_conv_descriptor_data_get (src);
907 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
909 /* Copy the offset. This is not changed by transposition; the top-left
910 element is still at the same offset as before, except where the loop
912 if (!integer_zerop (loop->from[0]))
913 dest_info->offset = gfc_conv_descriptor_offset_get (src);
915 dest_info->offset = gfc_index_zero_node;
917 gfc_conv_descriptor_offset_set (&se->pre, dest,
920 if (dest_info->dimen > loop->temp_dim)
921 loop->temp_dim = dest_info->dimen;
925 /* Return the number of iterations in a loop that starts at START,
926 ends at END, and has step STEP. */
929 gfc_get_iteration_count (tree start, tree end, tree step)
934 type = TREE_TYPE (step);
935 tmp = fold_build2 (MINUS_EXPR, type, end, start);
936 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
937 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
938 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
939 return fold_convert (gfc_array_index_type, tmp);
943 /* Extend the data in array DESC by EXTRA elements. */
946 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
953 if (integer_zerop (extra))
956 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
958 /* Add EXTRA to the upper bound. */
959 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
960 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
962 /* Get the value of the current data pointer. */
963 arg0 = gfc_conv_descriptor_data_get (desc);
965 /* Calculate the new array size. */
966 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
967 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
968 ubound, gfc_index_one_node);
969 arg1 = fold_build2 (MULT_EXPR, size_type_node,
970 fold_convert (size_type_node, tmp),
971 fold_convert (size_type_node, size));
973 /* Call the realloc() function. */
974 tmp = gfc_call_realloc (pblock, arg0, arg1);
975 gfc_conv_descriptor_data_set (pblock, desc, tmp);
979 /* Return true if the bounds of iterator I can only be determined
983 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
985 return (i->start->expr_type != EXPR_CONSTANT
986 || i->end->expr_type != EXPR_CONSTANT
987 || i->step->expr_type != EXPR_CONSTANT);
991 /* Split the size of constructor element EXPR into the sum of two terms,
992 one of which can be determined at compile time and one of which must
993 be calculated at run time. Set *SIZE to the former and return true
994 if the latter might be nonzero. */
997 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
999 if (expr->expr_type == EXPR_ARRAY)
1000 return gfc_get_array_constructor_size (size, expr->value.constructor);
1001 else if (expr->rank > 0)
1003 /* Calculate everything at run time. */
1004 mpz_set_ui (*size, 0);
1009 /* A single element. */
1010 mpz_set_ui (*size, 1);
1016 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1017 of array constructor C. */
1020 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1028 mpz_set_ui (*size, 0);
1033 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1036 if (i && gfc_iterator_has_dynamic_bounds (i))
1040 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1043 /* Multiply the static part of the element size by the
1044 number of iterations. */
1045 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1046 mpz_fdiv_q (val, val, i->step->value.integer);
1047 mpz_add_ui (val, val, 1);
1048 if (mpz_sgn (val) > 0)
1049 mpz_mul (len, len, val);
1051 mpz_set_ui (len, 0);
1053 mpz_add (*size, *size, len);
1062 /* Make sure offset is a variable. */
1065 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1068 /* We should have already created the offset variable. We cannot
1069 create it here because we may be in an inner scope. */
1070 gcc_assert (*offsetvar != NULL_TREE);
1071 gfc_add_modify (pblock, *offsetvar, *poffset);
1072 *poffset = *offsetvar;
1073 TREE_USED (*offsetvar) = 1;
1077 /* Variables needed for bounds-checking. */
1078 static bool first_len;
1079 static tree first_len_val;
1080 static bool typespec_chararray_ctor;
1083 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1084 tree offset, gfc_se * se, gfc_expr * expr)
1088 gfc_conv_expr (se, expr);
1090 /* Store the value. */
1091 tmp = build_fold_indirect_ref_loc (input_location,
1092 gfc_conv_descriptor_data_get (desc));
1093 tmp = gfc_build_array_ref (tmp, offset, NULL);
1095 if (expr->ts.type == BT_CHARACTER)
1097 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1100 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1101 esize = fold_convert (gfc_charlen_type_node, esize);
1102 esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1103 build_int_cst (gfc_charlen_type_node,
1104 gfc_character_kinds[i].bit_size / 8));
1106 gfc_conv_string_parameter (se);
1107 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1109 /* The temporary is an array of pointers. */
1110 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1111 gfc_add_modify (&se->pre, tmp, se->expr);
1115 /* The temporary is an array of string values. */
1116 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1117 /* We know the temporary and the value will be the same length,
1118 so can use memcpy. */
1119 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1120 se->string_length, se->expr, expr->ts.kind);
1122 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1126 gfc_add_modify (&se->pre, first_len_val,
1132 /* Verify that all constructor elements are of the same
1134 tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1135 first_len_val, se->string_length);
1136 gfc_trans_runtime_check
1137 (true, false, cond, &se->pre, &expr->where,
1138 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1139 fold_convert (long_integer_type_node, first_len_val),
1140 fold_convert (long_integer_type_node, se->string_length));
1146 /* TODO: Should the frontend already have done this conversion? */
1147 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1148 gfc_add_modify (&se->pre, tmp, se->expr);
1151 gfc_add_block_to_block (pblock, &se->pre);
1152 gfc_add_block_to_block (pblock, &se->post);
1156 /* Add the contents of an array to the constructor. DYNAMIC is as for
1157 gfc_trans_array_constructor_value. */
1160 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1161 tree type ATTRIBUTE_UNUSED,
1162 tree desc, gfc_expr * expr,
1163 tree * poffset, tree * offsetvar,
1174 /* We need this to be a variable so we can increment it. */
1175 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1177 gfc_init_se (&se, NULL);
1179 /* Walk the array expression. */
1180 ss = gfc_walk_expr (expr);
1181 gcc_assert (ss != gfc_ss_terminator);
1183 /* Initialize the scalarizer. */
1184 gfc_init_loopinfo (&loop);
1185 gfc_add_ss_to_loop (&loop, ss);
1187 /* Initialize the loop. */
1188 gfc_conv_ss_startstride (&loop);
1189 gfc_conv_loop_setup (&loop, &expr->where);
1191 /* Make sure the constructed array has room for the new data. */
1194 /* Set SIZE to the total number of elements in the subarray. */
1195 size = gfc_index_one_node;
1196 for (n = 0; n < loop.dimen; n++)
1198 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1199 gfc_index_one_node);
1200 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1203 /* Grow the constructed array by SIZE elements. */
1204 gfc_grow_array (&loop.pre, desc, size);
1207 /* Make the loop body. */
1208 gfc_mark_ss_chain_used (ss, 1);
1209 gfc_start_scalarized_body (&loop, &body);
1210 gfc_copy_loopinfo_to_se (&se, &loop);
1213 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1214 gcc_assert (se.ss == gfc_ss_terminator);
1216 /* Increment the offset. */
1217 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1218 *poffset, gfc_index_one_node);
1219 gfc_add_modify (&body, *poffset, tmp);
1221 /* Finish the loop. */
1222 gfc_trans_scalarizing_loops (&loop, &body);
1223 gfc_add_block_to_block (&loop.pre, &loop.post);
1224 tmp = gfc_finish_block (&loop.pre);
1225 gfc_add_expr_to_block (pblock, tmp);
1227 gfc_cleanup_loop (&loop);
1231 /* Assign the values to the elements of an array constructor. DYNAMIC
1232 is true if descriptor DESC only contains enough data for the static
1233 size calculated by gfc_get_array_constructor_size. When true, memory
1234 for the dynamic parts must be allocated using realloc. */
1237 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1238 tree desc, gfc_constructor_base base,
1239 tree * poffset, tree * offsetvar,
1248 tree shadow_loopvar = NULL_TREE;
1249 gfc_saved_var saved_loopvar;
1252 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1254 /* If this is an iterator or an array, the offset must be a variable. */
1255 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1256 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1258 /* Shadowing the iterator avoids changing its value and saves us from
1259 keeping track of it. Further, it makes sure that there's always a
1260 backend-decl for the symbol, even if there wasn't one before,
1261 e.g. in the case of an iterator that appears in a specification
1262 expression in an interface mapping. */
1265 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1266 tree type = gfc_typenode_for_spec (&sym->ts);
1268 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1269 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1272 gfc_start_block (&body);
1274 if (c->expr->expr_type == EXPR_ARRAY)
1276 /* Array constructors can be nested. */
1277 gfc_trans_array_constructor_value (&body, type, desc,
1278 c->expr->value.constructor,
1279 poffset, offsetvar, dynamic);
1281 else if (c->expr->rank > 0)
1283 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1284 poffset, offsetvar, dynamic);
1288 /* This code really upsets the gimplifier so don't bother for now. */
1295 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1297 p = gfc_constructor_next (p);
1302 /* Scalar values. */
1303 gfc_init_se (&se, NULL);
1304 gfc_trans_array_ctor_element (&body, desc, *poffset,
1307 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1308 *poffset, gfc_index_one_node);
1312 /* Collect multiple scalar constants into a constructor. */
1313 VEC(constructor_elt,gc) *v = NULL;
1317 HOST_WIDE_INT idx = 0;
1320 /* Count the number of consecutive scalar constants. */
1321 while (p && !(p->iterator
1322 || p->expr->expr_type != EXPR_CONSTANT))
1324 gfc_init_se (&se, NULL);
1325 gfc_conv_constant (&se, p->expr);
1327 if (c->expr->ts.type != BT_CHARACTER)
1328 se.expr = fold_convert (type, se.expr);
1329 /* For constant character array constructors we build
1330 an array of pointers. */
1331 else if (POINTER_TYPE_P (type))
1332 se.expr = gfc_build_addr_expr
1333 (gfc_get_pchar_type (p->expr->ts.kind),
1336 CONSTRUCTOR_APPEND_ELT (v,
1337 build_int_cst (gfc_array_index_type,
1341 p = gfc_constructor_next (p);
1344 bound = build_int_cst (NULL_TREE, n - 1);
1345 /* Create an array type to hold them. */
1346 tmptype = build_range_type (gfc_array_index_type,
1347 gfc_index_zero_node, bound);
1348 tmptype = build_array_type (type, tmptype);
1350 init = build_constructor (tmptype, v);
1351 TREE_CONSTANT (init) = 1;
1352 TREE_STATIC (init) = 1;
1353 /* Create a static variable to hold the data. */
1354 tmp = gfc_create_var (tmptype, "data");
1355 TREE_STATIC (tmp) = 1;
1356 TREE_CONSTANT (tmp) = 1;
1357 TREE_READONLY (tmp) = 1;
1358 DECL_INITIAL (tmp) = init;
1361 /* Use BUILTIN_MEMCPY to assign the values. */
1362 tmp = gfc_conv_descriptor_data_get (desc);
1363 tmp = build_fold_indirect_ref_loc (input_location,
1365 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1366 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1367 init = gfc_build_addr_expr (NULL_TREE, init);
1369 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1370 bound = build_int_cst (NULL_TREE, n * size);
1371 tmp = build_call_expr_loc (input_location,
1372 built_in_decls[BUILT_IN_MEMCPY], 3,
1374 gfc_add_expr_to_block (&body, tmp);
1376 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1378 build_int_cst (gfc_array_index_type, n));
1380 if (!INTEGER_CST_P (*poffset))
1382 gfc_add_modify (&body, *offsetvar, *poffset);
1383 *poffset = *offsetvar;
1387 /* The frontend should already have done any expansions
1391 /* Pass the code as is. */
1392 tmp = gfc_finish_block (&body);
1393 gfc_add_expr_to_block (pblock, tmp);
1397 /* Build the implied do-loop. */
1398 stmtblock_t implied_do_block;
1406 loopbody = gfc_finish_block (&body);
1408 /* Create a new block that holds the implied-do loop. A temporary
1409 loop-variable is used. */
1410 gfc_start_block(&implied_do_block);
1412 /* Initialize the loop. */
1413 gfc_init_se (&se, NULL);
1414 gfc_conv_expr_val (&se, c->iterator->start);
1415 gfc_add_block_to_block (&implied_do_block, &se.pre);
1416 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1418 gfc_init_se (&se, NULL);
1419 gfc_conv_expr_val (&se, c->iterator->end);
1420 gfc_add_block_to_block (&implied_do_block, &se.pre);
1421 end = gfc_evaluate_now (se.expr, &implied_do_block);
1423 gfc_init_se (&se, NULL);
1424 gfc_conv_expr_val (&se, c->iterator->step);
1425 gfc_add_block_to_block (&implied_do_block, &se.pre);
1426 step = gfc_evaluate_now (se.expr, &implied_do_block);
1428 /* If this array expands dynamically, and the number of iterations
1429 is not constant, we won't have allocated space for the static
1430 part of C->EXPR's size. Do that now. */
1431 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1433 /* Get the number of iterations. */
1434 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1436 /* Get the static part of C->EXPR's size. */
1437 gfc_get_array_constructor_element_size (&size, c->expr);
1438 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1440 /* Grow the array by TMP * TMP2 elements. */
1441 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1442 gfc_grow_array (&implied_do_block, desc, tmp);
1445 /* Generate the loop body. */
1446 exit_label = gfc_build_label_decl (NULL_TREE);
1447 gfc_start_block (&body);
1449 /* Generate the exit condition. Depending on the sign of
1450 the step variable we have to generate the correct
1452 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1453 build_int_cst (TREE_TYPE (step), 0));
1454 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1455 fold_build2 (GT_EXPR, boolean_type_node,
1456 shadow_loopvar, end),
1457 fold_build2 (LT_EXPR, boolean_type_node,
1458 shadow_loopvar, end));
1459 tmp = build1_v (GOTO_EXPR, exit_label);
1460 TREE_USED (exit_label) = 1;
1461 tmp = build3_v (COND_EXPR, cond, tmp,
1462 build_empty_stmt (input_location));
1463 gfc_add_expr_to_block (&body, tmp);
1465 /* The main loop body. */
1466 gfc_add_expr_to_block (&body, loopbody);
1468 /* Increase loop variable by step. */
1469 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1470 gfc_add_modify (&body, shadow_loopvar, tmp);
1472 /* Finish the loop. */
1473 tmp = gfc_finish_block (&body);
1474 tmp = build1_v (LOOP_EXPR, tmp);
1475 gfc_add_expr_to_block (&implied_do_block, tmp);
1477 /* Add the exit label. */
1478 tmp = build1_v (LABEL_EXPR, exit_label);
1479 gfc_add_expr_to_block (&implied_do_block, tmp);
1481 /* Finishe the implied-do loop. */
1482 tmp = gfc_finish_block(&implied_do_block);
1483 gfc_add_expr_to_block(pblock, tmp);
1485 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1492 /* Figure out the string length of a variable reference expression.
1493 Used by get_array_ctor_strlen. */
1496 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1502 /* Don't bother if we already know the length is a constant. */
1503 if (*len && INTEGER_CST_P (*len))
1506 ts = &expr->symtree->n.sym->ts;
1507 for (ref = expr->ref; ref; ref = ref->next)
1512 /* Array references don't change the string length. */
1516 /* Use the length of the component. */
1517 ts = &ref->u.c.component->ts;
1521 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1522 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1524 mpz_init_set_ui (char_len, 1);
1525 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1526 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1527 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1528 *len = convert (gfc_charlen_type_node, *len);
1529 mpz_clear (char_len);
1533 /* TODO: Substrings are tricky because we can't evaluate the
1534 expression more than once. For now we just give up, and hope
1535 we can figure it out elsewhere. */
1540 *len = ts->u.cl->backend_decl;
1544 /* A catch-all to obtain the string length for anything that is not a
1545 constant, array or variable. */
1547 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1552 /* Don't bother if we already know the length is a constant. */
1553 if (*len && INTEGER_CST_P (*len))
1556 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1557 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1560 gfc_conv_const_charlen (e->ts.u.cl);
1561 *len = e->ts.u.cl->backend_decl;
1565 /* Otherwise, be brutal even if inefficient. */
1566 ss = gfc_walk_expr (e);
1567 gfc_init_se (&se, NULL);
1569 /* No function call, in case of side effects. */
1570 se.no_function_call = 1;
1571 if (ss == gfc_ss_terminator)
1572 gfc_conv_expr (&se, e);
1574 gfc_conv_expr_descriptor (&se, e, ss);
1576 /* Fix the value. */
1577 *len = gfc_evaluate_now (se.string_length, &se.pre);
1579 gfc_add_block_to_block (block, &se.pre);
1580 gfc_add_block_to_block (block, &se.post);
1582 e->ts.u.cl->backend_decl = *len;
1587 /* Figure out the string length of a character array constructor.
1588 If len is NULL, don't calculate the length; this happens for recursive calls
1589 when a sub-array-constructor is an element but not at the first position,
1590 so when we're not interested in the length.
1591 Returns TRUE if all elements are character constants. */
1594 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1601 if (gfc_constructor_first (base) == NULL)
1604 *len = build_int_cstu (gfc_charlen_type_node, 0);
1608 /* Loop over all constructor elements to find out is_const, but in len we
1609 want to store the length of the first, not the last, element. We can
1610 of course exit the loop as soon as is_const is found to be false. */
1611 for (c = gfc_constructor_first (base);
1612 c && is_const; c = gfc_constructor_next (c))
1614 switch (c->expr->expr_type)
1617 if (len && !(*len && INTEGER_CST_P (*len)))
1618 *len = build_int_cstu (gfc_charlen_type_node,
1619 c->expr->value.character.length);
1623 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1630 get_array_ctor_var_strlen (c->expr, len);
1636 get_array_ctor_all_strlen (block, c->expr, len);
1640 /* After the first iteration, we don't want the length modified. */
1647 /* Check whether the array constructor C consists entirely of constant
1648 elements, and if so returns the number of those elements, otherwise
1649 return zero. Note, an empty or NULL array constructor returns zero. */
1651 unsigned HOST_WIDE_INT
1652 gfc_constant_array_constructor_p (gfc_constructor_base base)
1654 unsigned HOST_WIDE_INT nelem = 0;
1656 gfc_constructor *c = gfc_constructor_first (base);
1660 || c->expr->rank > 0
1661 || c->expr->expr_type != EXPR_CONSTANT)
1663 c = gfc_constructor_next (c);
1670 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1671 and the tree type of it's elements, TYPE, return a static constant
1672 variable that is compile-time initialized. */
1675 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1677 tree tmptype, init, tmp;
1678 HOST_WIDE_INT nelem;
1683 VEC(constructor_elt,gc) *v = NULL;
1685 /* First traverse the constructor list, converting the constants
1686 to tree to build an initializer. */
1688 c = gfc_constructor_first (expr->value.constructor);
1691 gfc_init_se (&se, NULL);
1692 gfc_conv_constant (&se, c->expr);
1693 if (c->expr->ts.type != BT_CHARACTER)
1694 se.expr = fold_convert (type, se.expr);
1695 else if (POINTER_TYPE_P (type))
1696 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1698 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1700 c = gfc_constructor_next (c);
1704 /* Next determine the tree type for the array. We use the gfortran
1705 front-end's gfc_get_nodesc_array_type in order to create a suitable
1706 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1708 memset (&as, 0, sizeof (gfc_array_spec));
1710 as.rank = expr->rank;
1711 as.type = AS_EXPLICIT;
1714 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1715 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1719 for (i = 0; i < expr->rank; i++)
1721 int tmp = (int) mpz_get_si (expr->shape[i]);
1722 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1723 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1727 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1729 init = build_constructor (tmptype, v);
1731 TREE_CONSTANT (init) = 1;
1732 TREE_STATIC (init) = 1;
1734 tmp = gfc_create_var (tmptype, "A");
1735 TREE_STATIC (tmp) = 1;
1736 TREE_CONSTANT (tmp) = 1;
1737 TREE_READONLY (tmp) = 1;
1738 DECL_INITIAL (tmp) = init;
1744 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1745 This mostly initializes the scalarizer state info structure with the
1746 appropriate values to directly use the array created by the function
1747 gfc_build_constant_array_constructor. */
1750 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1751 gfc_ss * ss, tree type)
1757 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1759 info = &ss->data.info;
1761 info->descriptor = tmp;
1762 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1763 info->offset = gfc_index_zero_node;
1765 for (i = 0; i < info->dimen; i++)
1767 info->delta[i] = gfc_index_zero_node;
1768 info->start[i] = gfc_index_zero_node;
1769 info->end[i] = gfc_index_zero_node;
1770 info->stride[i] = gfc_index_one_node;
1774 if (info->dimen > loop->temp_dim)
1775 loop->temp_dim = info->dimen;
1778 /* Helper routine of gfc_trans_array_constructor to determine if the
1779 bounds of the loop specified by LOOP are constant and simple enough
1780 to use with gfc_trans_constant_array_constructor. Returns the
1781 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1784 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1786 tree size = gfc_index_one_node;
1790 for (i = 0; i < loop->dimen; i++)
1792 /* If the bounds aren't constant, return NULL_TREE. */
1793 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1795 if (!integer_zerop (loop->from[i]))
1797 /* Only allow nonzero "from" in one-dimensional arrays. */
1798 if (loop->dimen != 1)
1800 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1801 loop->to[i], loop->from[i]);
1805 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1806 tmp, gfc_index_one_node);
1807 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1814 /* Array constructors are handled by constructing a temporary, then using that
1815 within the scalarization loop. This is not optimal, but seems by far the
1819 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1821 gfc_constructor_base c;
1827 bool old_first_len, old_typespec_chararray_ctor;
1828 tree old_first_len_val;
1830 /* Save the old values for nested checking. */
1831 old_first_len = first_len;
1832 old_first_len_val = first_len_val;
1833 old_typespec_chararray_ctor = typespec_chararray_ctor;
1835 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1836 typespec was given for the array constructor. */
1837 typespec_chararray_ctor = (ss->expr->ts.u.cl
1838 && ss->expr->ts.u.cl->length_from_typespec);
1840 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1841 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1843 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1847 ss->data.info.dimen = loop->dimen;
1849 c = ss->expr->value.constructor;
1850 if (ss->expr->ts.type == BT_CHARACTER)
1854 /* get_array_ctor_strlen walks the elements of the constructor, if a
1855 typespec was given, we already know the string length and want the one
1857 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1858 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1862 const_string = false;
1863 gfc_init_se (&length_se, NULL);
1864 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1865 gfc_charlen_type_node);
1866 ss->string_length = length_se.expr;
1867 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1868 gfc_add_block_to_block (&loop->post, &length_se.post);
1871 const_string = get_array_ctor_strlen (&loop->pre, c,
1872 &ss->string_length);
1874 /* Complex character array constructors should have been taken care of
1875 and not end up here. */
1876 gcc_assert (ss->string_length);
1878 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1880 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1882 type = build_pointer_type (type);
1885 type = gfc_typenode_for_spec (&ss->expr->ts);
1887 /* See if the constructor determines the loop bounds. */
1890 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1892 /* We have a multidimensional parameter. */
1894 for (n = 0; n < ss->expr->rank; n++)
1896 loop->from[n] = gfc_index_zero_node;
1897 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1898 gfc_index_integer_kind);
1899 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1900 loop->to[n], gfc_index_one_node);
1904 if (loop->to[0] == NULL_TREE)
1908 /* We should have a 1-dimensional, zero-based loop. */
1909 gcc_assert (loop->dimen == 1);
1910 gcc_assert (integer_zerop (loop->from[0]));
1912 /* Split the constructor size into a static part and a dynamic part.
1913 Allocate the static size up-front and record whether the dynamic
1914 size might be nonzero. */
1916 dynamic = gfc_get_array_constructor_size (&size, c);
1917 mpz_sub_ui (size, size, 1);
1918 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1922 /* Special case constant array constructors. */
1925 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1928 tree size = constant_array_constructor_loop_size (loop);
1929 if (size && compare_tree_int (size, nelem) == 0)
1931 gfc_trans_constant_array_constructor (loop, ss, type);
1937 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1938 type, NULL_TREE, dynamic, true, false, where);
1940 desc = ss->data.info.descriptor;
1941 offset = gfc_index_zero_node;
1942 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1943 TREE_NO_WARNING (offsetvar) = 1;
1944 TREE_USED (offsetvar) = 0;
1945 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1946 &offset, &offsetvar, dynamic);
1948 /* If the array grows dynamically, the upper bound of the loop variable
1949 is determined by the array's final upper bound. */
1951 loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1953 if (TREE_USED (offsetvar))
1954 pushdecl (offsetvar);
1956 gcc_assert (INTEGER_CST_P (offset));
1958 /* Disable bound checking for now because it's probably broken. */
1959 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1966 /* Restore old values of globals. */
1967 first_len = old_first_len;
1968 first_len_val = old_first_len_val;
1969 typespec_chararray_ctor = old_typespec_chararray_ctor;
1973 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1974 called after evaluating all of INFO's vector dimensions. Go through
1975 each such vector dimension and see if we can now fill in any missing
1979 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1988 for (n = 0; n < loop->dimen; n++)
1991 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1992 && loop->to[n] == NULL)
1994 /* Loop variable N indexes vector dimension DIM, and we don't
1995 yet know the upper bound of loop variable N. Set it to the
1996 difference between the vector's upper and lower bounds. */
1997 gcc_assert (loop->from[n] == gfc_index_zero_node);
1998 gcc_assert (info->subscript[dim]
1999 && info->subscript[dim]->type == GFC_SS_VECTOR);
2001 gfc_init_se (&se, NULL);
2002 desc = info->subscript[dim]->data.info.descriptor;
2003 zero = gfc_rank_cst[0];
2004 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2005 gfc_conv_descriptor_ubound_get (desc, zero),
2006 gfc_conv_descriptor_lbound_get (desc, zero));
2007 tmp = gfc_evaluate_now (tmp, &loop->pre);
2014 /* Add the pre and post chains for all the scalar expressions in a SS chain
2015 to loop. This is called after the loop parameters have been calculated,
2016 but before the actual scalarizing loops. */
2019 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2025 /* TODO: This can generate bad code if there are ordering dependencies,
2026 e.g., a callee allocated function and an unknown size constructor. */
2027 gcc_assert (ss != NULL);
2029 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2036 /* Scalar expression. Evaluate this now. This includes elemental
2037 dimension indices, but not array section bounds. */
2038 gfc_init_se (&se, NULL);
2039 gfc_conv_expr (&se, ss->expr);
2040 gfc_add_block_to_block (&loop->pre, &se.pre);
2042 if (ss->expr->ts.type != BT_CHARACTER)
2044 /* Move the evaluation of scalar expressions outside the
2045 scalarization loop, except for WHERE assignments. */
2047 se.expr = convert(gfc_array_index_type, se.expr);
2049 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2050 gfc_add_block_to_block (&loop->pre, &se.post);
2053 gfc_add_block_to_block (&loop->post, &se.post);
2055 ss->data.scalar.expr = se.expr;
2056 ss->string_length = se.string_length;
2059 case GFC_SS_REFERENCE:
2060 /* Scalar argument to elemental procedure. Evaluate this
2062 gfc_init_se (&se, NULL);
2063 gfc_conv_expr (&se, ss->expr);
2064 gfc_add_block_to_block (&loop->pre, &se.pre);
2065 gfc_add_block_to_block (&loop->post, &se.post);
2067 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2068 ss->string_length = se.string_length;
2071 case GFC_SS_SECTION:
2072 /* Add the expressions for scalar and vector subscripts. */
2073 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2074 if (ss->data.info.subscript[n])
2075 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2078 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2082 /* Get the vector's descriptor and store it in SS. */
2083 gfc_init_se (&se, NULL);
2084 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2085 gfc_add_block_to_block (&loop->pre, &se.pre);
2086 gfc_add_block_to_block (&loop->post, &se.post);
2087 ss->data.info.descriptor = se.expr;
2090 case GFC_SS_INTRINSIC:
2091 gfc_add_intrinsic_ss_code (loop, ss);
2094 case GFC_SS_FUNCTION:
2095 /* Array function return value. We call the function and save its
2096 result in a temporary for use inside the loop. */
2097 gfc_init_se (&se, NULL);
2100 gfc_conv_expr (&se, ss->expr);
2101 gfc_add_block_to_block (&loop->pre, &se.pre);
2102 gfc_add_block_to_block (&loop->post, &se.post);
2103 ss->string_length = se.string_length;
2106 case GFC_SS_CONSTRUCTOR:
2107 if (ss->expr->ts.type == BT_CHARACTER
2108 && ss->string_length == NULL
2109 && ss->expr->ts.u.cl
2110 && ss->expr->ts.u.cl->length)
2112 gfc_init_se (&se, NULL);
2113 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2114 gfc_charlen_type_node);
2115 ss->string_length = se.expr;
2116 gfc_add_block_to_block (&loop->pre, &se.pre);
2117 gfc_add_block_to_block (&loop->post, &se.post);
2119 gfc_trans_array_constructor (loop, ss, where);
2123 case GFC_SS_COMPONENT:
2124 /* Do nothing. These are handled elsewhere. */
2134 /* Translate expressions for the descriptor and data pointer of a SS. */
2138 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2143 /* Get the descriptor for the array to be scalarized. */
2144 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2145 gfc_init_se (&se, NULL);
2146 se.descriptor_only = 1;
2147 gfc_conv_expr_lhs (&se, ss->expr);
2148 gfc_add_block_to_block (block, &se.pre);
2149 ss->data.info.descriptor = se.expr;
2150 ss->string_length = se.string_length;
2154 /* Also the data pointer. */
2155 tmp = gfc_conv_array_data (se.expr);
2156 /* If this is a variable or address of a variable we use it directly.
2157 Otherwise we must evaluate it now to avoid breaking dependency
2158 analysis by pulling the expressions for elemental array indices
2161 || (TREE_CODE (tmp) == ADDR_EXPR
2162 && DECL_P (TREE_OPERAND (tmp, 0)))))
2163 tmp = gfc_evaluate_now (tmp, block);
2164 ss->data.info.data = tmp;
2166 tmp = gfc_conv_array_offset (se.expr);
2167 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2172 /* Initialize a gfc_loopinfo structure. */
2175 gfc_init_loopinfo (gfc_loopinfo * loop)
2179 memset (loop, 0, sizeof (gfc_loopinfo));
2180 gfc_init_block (&loop->pre);
2181 gfc_init_block (&loop->post);
2183 /* Initially scalarize in order and default to no loop reversal. */
2184 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2187 loop->reverse[n] = GFC_CANNOT_REVERSE;
2190 loop->ss = gfc_ss_terminator;
2194 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2198 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2204 /* Return an expression for the data pointer of an array. */
2207 gfc_conv_array_data (tree descriptor)
2211 type = TREE_TYPE (descriptor);
2212 if (GFC_ARRAY_TYPE_P (type))
2214 if (TREE_CODE (type) == POINTER_TYPE)
2218 /* Descriptorless arrays. */
2219 return gfc_build_addr_expr (NULL_TREE, descriptor);
2223 return gfc_conv_descriptor_data_get (descriptor);
2227 /* Return an expression for the base offset of an array. */
2230 gfc_conv_array_offset (tree descriptor)
2234 type = TREE_TYPE (descriptor);
2235 if (GFC_ARRAY_TYPE_P (type))
2236 return GFC_TYPE_ARRAY_OFFSET (type);
2238 return gfc_conv_descriptor_offset_get (descriptor);
2242 /* Get an expression for the array stride. */
2245 gfc_conv_array_stride (tree descriptor, int dim)
2250 type = TREE_TYPE (descriptor);
2252 /* For descriptorless arrays use the array size. */
2253 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2254 if (tmp != NULL_TREE)
2257 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2262 /* Like gfc_conv_array_stride, but for the lower bound. */
2265 gfc_conv_array_lbound (tree descriptor, int dim)
2270 type = TREE_TYPE (descriptor);
2272 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2273 if (tmp != NULL_TREE)
2276 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2281 /* Like gfc_conv_array_stride, but for the upper bound. */
2284 gfc_conv_array_ubound (tree descriptor, int dim)
2289 type = TREE_TYPE (descriptor);
2291 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2292 if (tmp != NULL_TREE)
2295 /* This should only ever happen when passing an assumed shape array
2296 as an actual parameter. The value will never be used. */
2297 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2298 return gfc_index_zero_node;
2300 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2305 /* Generate code to perform an array index bound check. */
2308 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2309 locus * where, bool check_upper)
2312 tree tmp_lo, tmp_up;
2314 const char * name = NULL;
2316 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2319 index = gfc_evaluate_now (index, &se->pre);
2321 /* We find a name for the error message. */
2323 name = se->ss->expr->symtree->name;
2325 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2326 && se->loop->ss->expr->symtree)
2327 name = se->loop->ss->expr->symtree->name;
2329 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2330 && se->loop->ss->loop_chain->expr
2331 && se->loop->ss->loop_chain->expr->symtree)
2332 name = se->loop->ss->loop_chain->expr->symtree->name;
2334 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2336 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2337 && se->loop->ss->expr->value.function.name)
2338 name = se->loop->ss->expr->value.function.name;
2340 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2341 || se->loop->ss->type == GFC_SS_SCALAR)
2342 name = "unnamed constant";
2345 if (TREE_CODE (descriptor) == VAR_DECL)
2346 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2348 /* If upper bound is present, include both bounds in the error message. */
2351 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2352 tmp_up = gfc_conv_array_ubound (descriptor, n);
2355 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2356 "outside of expected range (%%ld:%%ld)", n+1, name);
2358 asprintf (&msg, "Index '%%ld' of dimension %d "
2359 "outside of expected range (%%ld:%%ld)", n+1);
2361 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2362 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2363 fold_convert (long_integer_type_node, index),
2364 fold_convert (long_integer_type_node, tmp_lo),
2365 fold_convert (long_integer_type_node, tmp_up));
2366 fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2367 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2368 fold_convert (long_integer_type_node, index),
2369 fold_convert (long_integer_type_node, tmp_lo),
2370 fold_convert (long_integer_type_node, tmp_up));
2375 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2378 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2379 "below lower bound of %%ld", n+1, name);
2381 asprintf (&msg, "Index '%%ld' of dimension %d "
2382 "below lower bound of %%ld", n+1);
2384 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2385 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2386 fold_convert (long_integer_type_node, index),
2387 fold_convert (long_integer_type_node, tmp_lo));
2395 /* Return the offset for an index. Performs bound checking for elemental
2396 dimensions. Single element references are processed separately.
2397 DIM is the array dimension, I is the loop dimension. */
2400 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2401 gfc_array_ref * ar, tree stride)
2407 /* Get the index into the array for this dimension. */
2410 gcc_assert (ar->type != AR_ELEMENT);
2411 switch (ar->dimen_type[dim])
2414 /* Elemental dimension. */
2415 gcc_assert (info->subscript[dim]
2416 && info->subscript[dim]->type == GFC_SS_SCALAR);
2417 /* We've already translated this value outside the loop. */
2418 index = info->subscript[dim]->data.scalar.expr;
2420 index = gfc_trans_array_bound_check (se, info->descriptor,
2421 index, dim, &ar->where,
2422 ar->as->type != AS_ASSUMED_SIZE
2423 || dim < ar->dimen - 1);
2427 gcc_assert (info && se->loop);
2428 gcc_assert (info->subscript[dim]
2429 && info->subscript[dim]->type == GFC_SS_VECTOR);
2430 desc = info->subscript[dim]->data.info.descriptor;
2432 /* Get a zero-based index into the vector. */
2433 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2434 se->loop->loopvar[i], se->loop->from[i]);
2436 /* Multiply the index by the stride. */
2437 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2438 index, gfc_conv_array_stride (desc, 0));
2440 /* Read the vector to get an index into info->descriptor. */
2441 data = build_fold_indirect_ref_loc (input_location,
2442 gfc_conv_array_data (desc));
2443 index = gfc_build_array_ref (data, index, NULL);
2444 index = gfc_evaluate_now (index, &se->pre);
2445 index = fold_convert (gfc_array_index_type, index);
2447 /* Do any bounds checking on the final info->descriptor index. */
2448 index = gfc_trans_array_bound_check (se, info->descriptor,
2449 index, dim, &ar->where,
2450 ar->as->type != AS_ASSUMED_SIZE
2451 || dim < ar->dimen - 1);
2455 /* Scalarized dimension. */
2456 gcc_assert (info && se->loop);
2458 /* Multiply the loop variable by the stride and delta. */
2459 index = se->loop->loopvar[i];
2460 if (!integer_onep (info->stride[dim]))
2461 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2463 if (!integer_zerop (info->delta[dim]))
2464 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2474 /* Temporary array or derived type component. */
2475 gcc_assert (se->loop);
2476 index = se->loop->loopvar[se->loop->order[i]];
2477 if (!integer_zerop (info->delta[dim]))
2478 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2479 index, info->delta[dim]);
2482 /* Multiply by the stride. */
2483 if (!integer_onep (stride))
2484 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2490 /* Build a scalarized reference to an array. */
2493 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2496 tree decl = NULL_TREE;
2501 info = &se->ss->data.info;
2503 n = se->loop->order[0];
2507 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2509 /* Add the offset for this dimension to the stored offset for all other
2511 if (!integer_zerop (info->offset))
2512 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2514 if (se->ss->expr && is_subref_array (se->ss->expr))
2515 decl = se->ss->expr->symtree->n.sym->backend_decl;
2517 tmp = build_fold_indirect_ref_loc (input_location,
2519 se->expr = gfc_build_array_ref (tmp, index, decl);
2523 /* Translate access of temporary array. */
2526 gfc_conv_tmp_array_ref (gfc_se * se)
2528 se->string_length = se->ss->string_length;
2529 gfc_conv_scalarized_array_ref (se, NULL);
2533 /* Build an array reference. se->expr already holds the array descriptor.
2534 This should be either a variable, indirect variable reference or component
2535 reference. For arrays which do not have a descriptor, se->expr will be
2537 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2540 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2553 /* Handle scalarized references separately. */
2554 if (ar->type != AR_ELEMENT)
2556 gfc_conv_scalarized_array_ref (se, ar);
2557 gfc_advance_se_ss_chain (se);
2561 index = gfc_index_zero_node;
2563 /* Calculate the offsets from all the dimensions. */
2564 for (n = 0; n < ar->dimen; n++)
2566 /* Calculate the index for this dimension. */
2567 gfc_init_se (&indexse, se);
2568 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2569 gfc_add_block_to_block (&se->pre, &indexse.pre);
2571 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2573 /* Check array bounds. */
2577 /* Evaluate the indexse.expr only once. */
2578 indexse.expr = save_expr (indexse.expr);
2581 tmp = gfc_conv_array_lbound (se->expr, n);
2582 if (sym->attr.temporary)
2584 gfc_init_se (&tmpse, se);
2585 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2586 gfc_array_index_type);
2587 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2591 cond = fold_build2 (LT_EXPR, boolean_type_node,
2593 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2594 "below lower bound of %%ld", n+1, sym->name);
2595 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2596 fold_convert (long_integer_type_node,
2598 fold_convert (long_integer_type_node, tmp));
2601 /* Upper bound, but not for the last dimension of assumed-size
2603 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2605 tmp = gfc_conv_array_ubound (se->expr, n);
2606 if (sym->attr.temporary)
2608 gfc_init_se (&tmpse, se);
2609 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2610 gfc_array_index_type);
2611 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2615 cond = fold_build2 (GT_EXPR, boolean_type_node,
2617 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2618 "above upper bound of %%ld", n+1, sym->name);
2619 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2620 fold_convert (long_integer_type_node,
2622 fold_convert (long_integer_type_node, tmp));
2627 /* Multiply the index by the stride. */
2628 stride = gfc_conv_array_stride (se->expr, n);
2629 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2632 /* And add it to the total. */
2633 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2636 tmp = gfc_conv_array_offset (se->expr);
2637 if (!integer_zerop (tmp))
2638 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2640 /* Access the calculated element. */
2641 tmp = gfc_conv_array_data (se->expr);
2642 tmp = build_fold_indirect_ref (tmp);
2643 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2647 /* Generate the code to be executed immediately before entering a
2648 scalarization loop. */
2651 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2652 stmtblock_t * pblock)
2661 /* This code will be executed before entering the scalarization loop
2662 for this dimension. */
2663 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2665 if ((ss->useflags & flag) == 0)
2668 if (ss->type != GFC_SS_SECTION
2669 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2670 && ss->type != GFC_SS_COMPONENT)
2673 info = &ss->data.info;
2675 if (dim >= info->dimen)
2678 if (dim == info->dimen - 1)
2680 /* For the outermost loop calculate the offset due to any
2681 elemental dimensions. It will have been initialized with the
2682 base offset of the array. */
2685 for (i = 0; i < info->ref->u.ar.dimen; i++)
2687 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2690 gfc_init_se (&se, NULL);
2692 se.expr = info->descriptor;
2693 stride = gfc_conv_array_stride (info->descriptor, i);
2694 index = gfc_conv_array_index_offset (&se, info, i, -1,
2697 gfc_add_block_to_block (pblock, &se.pre);
2699 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2700 info->offset, index);
2701 info->offset = gfc_evaluate_now (info->offset, pblock);
2705 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2708 stride = gfc_conv_array_stride (info->descriptor, 0);
2710 /* Calculate the stride of the innermost loop. Hopefully this will
2711 allow the backend optimizers to do their stuff more effectively.
2713 info->stride0 = gfc_evaluate_now (stride, pblock);
2717 /* Add the offset for the previous loop dimension. */
2722 ar = &info->ref->u.ar;
2723 i = loop->order[dim + 1];
2731 gfc_init_se (&se, NULL);
2733 se.expr = info->descriptor;
2734 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2735 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2737 gfc_add_block_to_block (pblock, &se.pre);
2738 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2739 info->offset, index);
2740 info->offset = gfc_evaluate_now (info->offset, pblock);
2743 /* Remember this offset for the second loop. */
2744 if (dim == loop->temp_dim - 1)
2745 info->saved_offset = info->offset;
2750 /* Start a scalarized expression. Creates a scope and declares loop
2754 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2760 gcc_assert (!loop->array_parameter);
2762 for (dim = loop->dimen - 1; dim >= 0; dim--)
2764 n = loop->order[dim];
2766 gfc_start_block (&loop->code[n]);
2768 /* Create the loop variable. */
2769 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2771 if (dim < loop->temp_dim)
2775 /* Calculate values that will be constant within this loop. */
2776 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2778 gfc_start_block (pbody);
2782 /* Generates the actual loop code for a scalarization loop. */
2785 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2786 stmtblock_t * pbody)
2797 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2798 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2799 && n == loop->dimen - 1)
2801 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2802 init = make_tree_vec (1);
2803 cond = make_tree_vec (1);
2804 incr = make_tree_vec (1);
2806 /* Cycle statement is implemented with a goto. Exit statement must not
2807 be present for this loop. */
2808 exit_label = gfc_build_label_decl (NULL_TREE);
2809 TREE_USED (exit_label) = 1;
2811 /* Label for cycle statements (if needed). */
2812 tmp = build1_v (LABEL_EXPR, exit_label);
2813 gfc_add_expr_to_block (pbody, tmp);
2815 stmt = make_node (OMP_FOR);
2817 TREE_TYPE (stmt) = void_type_node;
2818 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2820 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2821 OMP_CLAUSE_SCHEDULE);
2822 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2823 = OMP_CLAUSE_SCHEDULE_STATIC;
2824 if (ompws_flags & OMPWS_NOWAIT)
2825 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2826 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2828 /* Initialize the loopvar. */
2829 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2831 OMP_FOR_INIT (stmt) = init;
2832 /* The exit condition. */
2833 TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2834 loop->loopvar[n], loop->to[n]);
2835 OMP_FOR_COND (stmt) = cond;
2836 /* Increment the loopvar. */
2837 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2838 loop->loopvar[n], gfc_index_one_node);
2839 TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2840 void_type_node, loop->loopvar[n], tmp);
2841 OMP_FOR_INCR (stmt) = incr;
2843 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2844 gfc_add_expr_to_block (&loop->code[n], stmt);
2848 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2849 && (loop->temp_ss == NULL);
2851 loopbody = gfc_finish_block (pbody);
2855 tmp = loop->from[n];
2856 loop->from[n] = loop->to[n];
2860 /* Initialize the loopvar. */
2861 if (loop->loopvar[n] != loop->from[n])
2862 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2864 exit_label = gfc_build_label_decl (NULL_TREE);
2866 /* Generate the loop body. */
2867 gfc_init_block (&block);
2869 /* The exit condition. */
2870 cond = fold_build2 (reverse_loop ? LT_EXPR : GT_EXPR,
2871 boolean_type_node, loop->loopvar[n], loop->to[n]);
2872 tmp = build1_v (GOTO_EXPR, exit_label);
2873 TREE_USED (exit_label) = 1;
2874 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2875 gfc_add_expr_to_block (&block, tmp);
2877 /* The main body. */
2878 gfc_add_expr_to_block (&block, loopbody);
2880 /* Increment the loopvar. */
2881 tmp = fold_build2 (reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2882 gfc_array_index_type, loop->loopvar[n],
2883 gfc_index_one_node);
2885 gfc_add_modify (&block, loop->loopvar[n], tmp);
2887 /* Build the loop. */
2888 tmp = gfc_finish_block (&block);
2889 tmp = build1_v (LOOP_EXPR, tmp);
2890 gfc_add_expr_to_block (&loop->code[n], tmp);
2892 /* Add the exit label. */
2893 tmp = build1_v (LABEL_EXPR, exit_label);
2894 gfc_add_expr_to_block (&loop->code[n], tmp);
2900 /* Finishes and generates the loops for a scalarized expression. */
2903 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2908 stmtblock_t *pblock;
2912 /* Generate the loops. */
2913 for (dim = 0; dim < loop->dimen; dim++)
2915 n = loop->order[dim];
2916 gfc_trans_scalarized_loop_end (loop, n, pblock);
2917 loop->loopvar[n] = NULL_TREE;
2918 pblock = &loop->code[n];
2921 tmp = gfc_finish_block (pblock);
2922 gfc_add_expr_to_block (&loop->pre, tmp);
2924 /* Clear all the used flags. */
2925 for (ss = loop->ss; ss; ss = ss->loop_chain)
2930 /* Finish the main body of a scalarized expression, and start the secondary
2934 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2938 stmtblock_t *pblock;
2942 /* We finish as many loops as are used by the temporary. */
2943 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2945 n = loop->order[dim];
2946 gfc_trans_scalarized_loop_end (loop, n, pblock);
2947 loop->loopvar[n] = NULL_TREE;
2948 pblock = &loop->code[n];
2951 /* We don't want to finish the outermost loop entirely. */
2952 n = loop->order[loop->temp_dim - 1];
2953 gfc_trans_scalarized_loop_end (loop, n, pblock);
2955 /* Restore the initial offsets. */
2956 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2958 if ((ss->useflags & 2) == 0)
2961 if (ss->type != GFC_SS_SECTION
2962 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2963 && ss->type != GFC_SS_COMPONENT)
2966 ss->data.info.offset = ss->data.info.saved_offset;
2969 /* Restart all the inner loops we just finished. */
2970 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2972 n = loop->order[dim];
2974 gfc_start_block (&loop->code[n]);
2976 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2978 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2981 /* Start a block for the secondary copying code. */
2982 gfc_start_block (body);
2986 /* Calculate the lower bound of an array section. */
2989 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
2998 gcc_assert (ss->type == GFC_SS_SECTION);
3000 info = &ss->data.info;
3002 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3004 /* We use a zero-based index to access the vector. */
3005 info->start[dim] = gfc_index_zero_node;
3006 info->stride[dim] = gfc_index_one_node;
3007 info->end[dim] = NULL;
3011 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3012 desc = info->descriptor;
3013 start = info->ref->u.ar.start[dim];
3014 end = info->ref->u.ar.end[dim];
3015 stride = info->ref->u.ar.stride[dim];
3017 /* Calculate the start of the range. For vector subscripts this will
3018 be the range of the vector. */
3021 /* Specified section start. */
3022 gfc_init_se (&se, NULL);
3023 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3024 gfc_add_block_to_block (&loop->pre, &se.pre);
3025 info->start[dim] = se.expr;
3029 /* No lower bound specified so use the bound of the array. */
3030 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3032 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3034 /* Similarly calculate the end. Although this is not used in the
3035 scalarizer, it is needed when checking bounds and where the end
3036 is an expression with side-effects. */
3039 /* Specified section start. */
3040 gfc_init_se (&se, NULL);
3041 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3042 gfc_add_block_to_block (&loop->pre, &se.pre);
3043 info->end[dim] = se.expr;
3047 /* No upper bound specified so use the bound of the array. */
3048 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3050 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3052 /* Calculate the stride. */
3054 info->stride[dim] = gfc_index_one_node;
3057 gfc_init_se (&se, NULL);
3058 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3059 gfc_add_block_to_block (&loop->pre, &se.pre);
3060 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3065 /* Calculates the range start and stride for a SS chain. Also gets the
3066 descriptor and data pointer. The range of vector subscripts is the size
3067 of the vector. Array bounds are also checked. */
3070 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3078 /* Determine the rank of the loop. */
3080 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3084 case GFC_SS_SECTION:
3085 case GFC_SS_CONSTRUCTOR:
3086 case GFC_SS_FUNCTION:
3087 case GFC_SS_COMPONENT:
3088 loop->dimen = ss->data.info.dimen;
3091 /* As usual, lbound and ubound are exceptions!. */
3092 case GFC_SS_INTRINSIC:
3093 switch (ss->expr->value.function.isym->id)
3095 case GFC_ISYM_LBOUND:
3096 case GFC_ISYM_UBOUND:
3097 loop->dimen = ss->data.info.dimen;
3108 /* We should have determined the rank of the expression by now. If
3109 not, that's bad news. */
3110 gcc_assert (loop->dimen != 0);
3112 /* Loop over all the SS in the chain. */
3113 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3115 if (ss->expr && ss->expr->shape && !ss->shape)
3116 ss->shape = ss->expr->shape;
3120 case GFC_SS_SECTION:
3121 /* Get the descriptor for the array. */
3122 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3124 for (n = 0; n < ss->data.info.dimen; n++)
3125 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
3128 case GFC_SS_INTRINSIC:
3129 switch (ss->expr->value.function.isym->id)
3131 /* Fall through to supply start and stride. */
3132 case GFC_ISYM_LBOUND:
3133 case GFC_ISYM_UBOUND:
3139 case GFC_SS_CONSTRUCTOR:
3140 case GFC_SS_FUNCTION:
3141 for (n = 0; n < ss->data.info.dimen; n++)
3143 ss->data.info.start[n] = gfc_index_zero_node;
3144 ss->data.info.end[n] = gfc_index_zero_node;
3145 ss->data.info.stride[n] = gfc_index_one_node;
3154 /* The rest is just runtime bound checking. */
3155 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3158 tree lbound, ubound;
3160 tree size[GFC_MAX_DIMENSIONS];
3161 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3166 gfc_start_block (&block);
3168 for (n = 0; n < loop->dimen; n++)
3169 size[n] = NULL_TREE;
3171 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3175 if (ss->type != GFC_SS_SECTION)
3178 gfc_start_block (&inner);
3180 /* TODO: range checking for mapped dimensions. */
3181 info = &ss->data.info;
3183 /* This code only checks ranges. Elemental and vector
3184 dimensions are checked later. */
3185 for (n = 0; n < loop->dimen; n++)
3190 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3193 if (dim == info->ref->u.ar.dimen - 1
3194 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3195 check_upper = false;
3199 /* Zero stride is not allowed. */
3200 tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[dim],
3201 gfc_index_zero_node);
3202 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3203 "of array '%s'", dim + 1, ss->expr->symtree->name);
3204 gfc_trans_runtime_check (true, false, tmp, &inner,
3205 &ss->expr->where, msg);
3208 desc = ss->data.info.descriptor;
3210 /* This is the run-time equivalent of resolve.c's
3211 check_dimension(). The logical is more readable there
3212 than it is here, with all the trees. */
3213 lbound = gfc_conv_array_lbound (desc, dim);
3214 end = info->end[dim];
3216 ubound = gfc_conv_array_ubound (desc, dim);
3220 /* non_zerosized is true when the selected range is not
3222 stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3223 info->stride[dim], gfc_index_zero_node);
3224 tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[dim],
3226 stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3229 stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3230 info->stride[dim], gfc_index_zero_node);
3231 tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[dim],
3233 stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3235 non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3236 stride_pos, stride_neg);
3238 /* Check the start of the range against the lower and upper
3239 bounds of the array, if the range is not empty.
3240 If upper bound is present, include both bounds in the
3244 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3245 info->start[dim], lbound);
3246 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3247 non_zerosized, tmp);
3248 tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3249 info->start[dim], ubound);
3250 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3251 non_zerosized, tmp2);
3252 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3253 "outside of expected range (%%ld:%%ld)",
3254 dim + 1, ss->expr->symtree->name);
3255 gfc_trans_runtime_check (true, false, tmp, &inner,
3256 &ss->expr->where, msg,
3257 fold_convert (long_integer_type_node, info->start[dim]),
3258 fold_convert (long_integer_type_node, lbound),
3259 fold_convert (long_integer_type_node, ubound));
3260 gfc_trans_runtime_check (true, false, tmp2, &inner,
3261 &ss->expr->where, msg,
3262 fold_convert (long_integer_type_node, info->start[dim]),
3263 fold_convert (long_integer_type_node, lbound),
3264 fold_convert (long_integer_type_node, ubound));
3269 tmp = fold_build2 (LT_EXPR, boolean_type_node,
3270 info->start[dim], lbound);
3271 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3272 non_zerosized, tmp);
3273 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3274 "below lower bound of %%ld",
3275 dim + 1, ss->expr->symtree->name);
3276 gfc_trans_runtime_check (true, false, tmp, &inner,
3277 &ss->expr->where, msg,
3278 fold_convert (long_integer_type_node, info->start[dim]),
3279 fold_convert (long_integer_type_node, lbound));
3283 /* Compute the last element of the range, which is not
3284 necessarily "end" (think 0:5:3, which doesn't contain 5)
3285 and check it against both lower and upper bounds. */
3287 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3289 tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3291 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3293 tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3294 tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3295 non_zerosized, tmp2);
3298 tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3299 tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3300 non_zerosized, tmp3);
3301 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3302 "outside of expected range (%%ld:%%ld)",
3303 dim + 1, ss->expr->symtree->name);
3304 gfc_trans_runtime_check (true, false, tmp2, &inner,
3305 &ss->expr->where, msg,
3306 fold_convert (long_integer_type_node, tmp),
3307 fold_convert (long_integer_type_node, ubound),
3308 fold_convert (long_integer_type_node, lbound));
3309 gfc_trans_runtime_check (true, false, tmp3, &inner,
3310 &ss->expr->where, msg,
3311 fold_convert (long_integer_type_node, tmp),
3312 fold_convert (long_integer_type_node, ubound),
3313 fold_convert (long_integer_type_node, lbound));
3318 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3319 "below lower bound of %%ld",
3320 dim + 1, ss->expr->symtree->name);
3321 gfc_trans_runtime_check (true, false, tmp2, &inner,
3322 &ss->expr->where, msg,
3323 fold_convert (long_integer_type_node, tmp),
3324 fold_convert (long_integer_type_node, lbound));
3328 /* Check the section sizes match. */
3329 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3331 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3333 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3334 gfc_index_one_node, tmp);
3335 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3336 build_int_cst (gfc_array_index_type, 0));
3337 /* We remember the size of the first section, and check all the
3338 others against this. */
3341 tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3342 asprintf (&msg, "Array bound mismatch for dimension %d "
3343 "of array '%s' (%%ld/%%ld)",
3344 dim + 1, ss->expr->symtree->name);
3346 gfc_trans_runtime_check (true, false, tmp3, &inner,
3347 &ss->expr->where, msg,
3348 fold_convert (long_integer_type_node, tmp),
3349 fold_convert (long_integer_type_node, size[n]));
3354 size[n] = gfc_evaluate_now (tmp, &inner);
3357 tmp = gfc_finish_block (&inner);
3359 /* For optional arguments, only check bounds if the argument is
3361 if (ss->expr->symtree->n.sym->attr.optional
3362 || ss->expr->symtree->n.sym->attr.not_always_present)
3363 tmp = build3_v (COND_EXPR,
3364 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3365 tmp, build_empty_stmt (input_location));
3367 gfc_add_expr_to_block (&block, tmp);
3371 tmp = gfc_finish_block (&block);
3372 gfc_add_expr_to_block (&loop->pre, tmp);
3377 /* Return true if the two SS could be aliased, i.e. both point to the same data
3379 /* TODO: resolve aliases based on frontend expressions. */
3382 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3389 lsym = lss->expr->symtree->n.sym;
3390 rsym = rss->expr->symtree->n.sym;
3391 if (gfc_symbols_could_alias (lsym, rsym))
3394 if (rsym->ts.type != BT_DERIVED
3395 && lsym->ts.type != BT_DERIVED)
3398 /* For derived types we must check all the component types. We can ignore
3399 array references as these will have the same base type as the previous
3401 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3403 if (lref->type != REF_COMPONENT)
3406 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3409 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3412 if (rref->type != REF_COMPONENT)
3415 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3420 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3422 if (rref->type != REF_COMPONENT)
3425 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3433 /* Resolve array data dependencies. Creates a temporary if required. */
3434 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3438 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3446 loop->temp_ss = NULL;
3448 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3450 if (ss->type != GFC_SS_SECTION)
3453 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3455 if (gfc_could_be_alias (dest, ss)
3456 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3464 lref = dest->expr->ref;
3465 rref = ss->expr->ref;
3467 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3472 /* TODO : loop shifting. */
3475 /* Mark the dimensions for LOOP SHIFTING */
3476 for (n = 0; n < loop->dimen; n++)
3478 int dim = dest->data.info.dim[n];
3480 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3482 else if (! gfc_is_same_range (&lref->u.ar,
3483 &rref->u.ar, dim, 0))
3487 /* Put all the dimensions with dependencies in the
3490 for (n = 0; n < loop->dimen; n++)
3492 gcc_assert (loop->order[n] == n);
3494 loop->order[dim++] = n;
3496 for (n = 0; n < loop->dimen; n++)
3499 loop->order[dim++] = n;
3502 gcc_assert (dim == loop->dimen);
3511 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3512 if (GFC_ARRAY_TYPE_P (base_type)
3513 || GFC_DESCRIPTOR_TYPE_P (base_type))
3514 base_type = gfc_get_element_type (base_type);
3515 loop->temp_ss = gfc_get_ss ();
3516 loop->temp_ss->type = GFC_SS_TEMP;
3517 loop->temp_ss->data.temp.type = base_type;
3518 loop->temp_ss->string_length = dest->string_length;
3519 loop->temp_ss->data.temp.dimen = loop->dimen;
3520 loop->temp_ss->next = gfc_ss_terminator;
3521 gfc_add_ss_to_loop (loop, loop->temp_ss);
3524 loop->temp_ss = NULL;
3528 /* Initialize the scalarization loop. Creates the loop variables. Determines
3529 the range of the loop variables. Creates a temporary if required.
3530 Calculates how to transform from loop variables to array indices for each
3531 expression. Also generates code for scalar expressions which have been
3532 moved outside the loop. */
3535 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3537 int n, dim, spec_dim;
3539 gfc_ss_info *specinfo;
3542 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3543 bool dynamic[GFC_MAX_DIMENSIONS];
3548 for (n = 0; n < loop->dimen; n++)
3552 /* We use one SS term, and use that to determine the bounds of the
3553 loop for this dimension. We try to pick the simplest term. */
3554 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3556 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3559 info = &ss->data.info;
3562 if (loopspec[n] != NULL)
3564 specinfo = &loopspec[n]->data.info;
3565 spec_dim = specinfo->dim[n];
3569 /* Silence unitialized warnings. */
3576 gcc_assert (ss->shape[dim]);
3577 /* The frontend has worked out the size for us. */
3579 || !loopspec[n]->shape
3580 || !integer_zerop (specinfo->start[spec_dim]))
3581 /* Prefer zero-based descriptors if possible. */
3586 if (ss->type == GFC_SS_CONSTRUCTOR)
3588 gfc_constructor_base base;
3589 /* An unknown size constructor will always be rank one.
3590 Higher rank constructors will either have known shape,
3591 or still be wrapped in a call to reshape. */
3592 gcc_assert (loop->dimen == 1);
3594 /* Always prefer to use the constructor bounds if the size
3595 can be determined at compile time. Prefer not to otherwise,
3596 since the general case involves realloc, and it's better to
3597 avoid that overhead if possible. */
3598 base = ss->expr->value.constructor;
3599 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3600 if (!dynamic[n] || !loopspec[n])
3605 /* TODO: Pick the best bound if we have a choice between a
3606 function and something else. */
3607 if (ss->type == GFC_SS_FUNCTION)
3613 if (ss->type != GFC_SS_SECTION)
3618 /* Criteria for choosing a loop specifier (most important first):
3619 doesn't need realloc
3625 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3627 else if (integer_onep (info->stride[dim])
3628 && !integer_onep (specinfo->stride[spec_dim]))
3630 else if (INTEGER_CST_P (info->stride[dim])
3631 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3633 else if (INTEGER_CST_P (info->start[dim])
3634 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3636 /* We don't work out the upper bound.
3637 else if (INTEGER_CST_P (info->finish[n])
3638 && ! INTEGER_CST_P (specinfo->finish[n]))
3639 loopspec[n] = ss; */
3642 /* We should have found the scalarization loop specifier. If not,
3644 gcc_assert (loopspec[n]);
3646 info = &loopspec[n]->data.info;
3649 /* Set the extents of this range. */
3650 cshape = loopspec[n]->shape;
3651 if (cshape && INTEGER_CST_P (info->start[dim])
3652 && INTEGER_CST_P (info->stride[dim]))
3654 loop->from[n] = info->start[dim];
3655 mpz_set (i, cshape[n]);
3656 mpz_sub_ui (i, i, 1);
3657 /* To = from + (size - 1) * stride. */
3658 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3659 if (!integer_onep (info->stride[dim]))
3660 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3661 tmp, info->stride[dim]);
3662 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3663 loop->from[n], tmp);
3667 loop->from[n] = info->start[dim];
3668 switch (loopspec[n]->type)
3670 case GFC_SS_CONSTRUCTOR:
3671 /* The upper bound is calculated when we expand the
3673 gcc_assert (loop->to[n] == NULL_TREE);
3676 case GFC_SS_SECTION:
3677 /* Use the end expression if it exists and is not constant,
3678 so that it is only evaluated once. */
3679 loop->to[n] = info->end[dim];
3682 case GFC_SS_FUNCTION:
3683 /* The loop bound will be set when we generate the call. */
3684 gcc_assert (loop->to[n] == NULL_TREE);
3692 /* Transform everything so we have a simple incrementing variable. */
3693 if (integer_onep (info->stride[dim]))
3694 info->delta[dim] = gfc_index_zero_node;
3697 /* Set the delta for this section. */
3698 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3699 /* Number of iterations is (end - start + step) / step.
3700 with start = 0, this simplifies to
3702 for (i = 0; i<=last; i++){...}; */
3703 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3704 loop->to[n], loop->from[n]);
3705 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
3706 tmp, info->stride[dim]);
3707 tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3708 build_int_cst (gfc_array_index_type, -1));
3709 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3710 /* Make the loop variable start at 0. */
3711 loop->from[n] = gfc_index_zero_node;
3715 /* Add all the scalar code that can be taken out of the loops.
3716 This may include calculating the loop bounds, so do it before
3717 allocating the temporary. */
3718 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3720 /* If we want a temporary then create it. */
3721 if (loop->temp_ss != NULL)
3723 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3725 /* Make absolutely sure that this is a complete type. */
3726 if (loop->temp_ss->string_length)
3727 loop->temp_ss->data.temp.type
3728 = gfc_get_character_type_len_for_eltype
3729 (TREE_TYPE (loop->temp_ss->data.temp.type),
3730 loop->temp_ss->string_length);
3732 tmp = loop->temp_ss->data.temp.type;
3733 n = loop->temp_ss->data.temp.dimen;
3734 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3735 loop->temp_ss->type = GFC_SS_SECTION;
3736 loop->temp_ss->data.info.dimen = n;
3737 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3738 &loop->temp_ss->data.info, tmp, NULL_TREE,
3739 false, true, false, where);
3742 for (n = 0; n < loop->temp_dim; n++)
3743 loopspec[loop->order[n]] = NULL;
3747 /* For array parameters we don't have loop variables, so don't calculate the
3749 if (loop->array_parameter)
3752 /* Calculate the translation from loop variables to array indices. */
3753 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3755 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3756 && ss->type != GFC_SS_CONSTRUCTOR)
3760 info = &ss->data.info;
3762 for (n = 0; n < info->dimen; n++)
3764 /* If we are specifying the range the delta is already set. */
3765 if (loopspec[n] != ss)
3767 dim = ss->data.info.dim[n];
3769 /* Calculate the offset relative to the loop variable.
3770 First multiply by the stride. */
3771 tmp = loop->from[n];
3772 if (!integer_onep (info->stride[dim]))
3773 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3774 tmp, info->stride[dim]);
3776 /* Then subtract this from our starting value. */
3777 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3778 info->start[dim], tmp);
3780 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
3787 /* Fills in an array descriptor, and returns the size of the array. The size
3788 will be a simple_val, ie a variable or a constant. Also calculates the
3789 offset of the base. Returns the size of the array.
3793 for (n = 0; n < rank; n++)
3795 a.lbound[n] = specified_lower_bound;
3796 offset = offset + a.lbond[n] * stride;
3798 a.ubound[n] = specified_upper_bound;
3799 a.stride[n] = stride;
3800 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3801 stride = stride * size;
3808 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
3809 gfc_expr ** lower, gfc_expr ** upper,
3810 stmtblock_t * pblock)
3822 stmtblock_t thenblock;
3823 stmtblock_t elseblock;
3828 type = TREE_TYPE (descriptor);
3830 stride = gfc_index_one_node;
3831 offset = gfc_index_zero_node;
3833 /* Set the dtype. */
3834 tmp = gfc_conv_descriptor_dtype (descriptor);
3835 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3837 or_expr = NULL_TREE;
3839 for (n = 0; n < rank; n++)
3841 /* We have 3 possibilities for determining the size of the array:
3842 lower == NULL => lbound = 1, ubound = upper[n]
3843 upper[n] = NULL => lbound = 1, ubound = lower[n]
3844 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
3847 /* Set lower bound. */
3848 gfc_init_se (&se, NULL);
3850 se.expr = gfc_index_one_node;
3853 gcc_assert (lower[n]);
3856 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3857 gfc_add_block_to_block (pblock, &se.pre);
3861 se.expr = gfc_index_one_node;
3865 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3868 /* Work out the offset for this component. */
3869 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3870 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3872 /* Start the calculation for the size of this dimension. */
3873 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3874 gfc_index_one_node, se.expr);
3876 /* Set upper bound. */
3877 gfc_init_se (&se, NULL);
3878 gcc_assert (ubound);
3879 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3880 gfc_add_block_to_block (pblock, &se.pre);
3882 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3884 /* Store the stride. */
3885 gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3887 /* Calculate the size of this dimension. */
3888 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3890 /* Check whether the size for this dimension is negative. */
3891 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3892 gfc_index_zero_node);
3896 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3898 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3899 gfc_index_zero_node, size);
3901 /* Multiply the stride by the number of elements in this dimension. */
3902 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3903 stride = gfc_evaluate_now (stride, pblock);
3906 for (n = rank; n < rank + corank; n++)
3910 /* Set lower bound. */
3911 gfc_init_se (&se, NULL);
3912 if (lower == NULL || lower[n] == NULL)
3914 gcc_assert (n == rank + corank - 1);
3915 se.expr = gfc_index_one_node;
3919 if (ubound || n == rank + corank - 1)
3921 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3922 gfc_add_block_to_block (pblock, &se.pre);
3926 se.expr = gfc_index_one_node;
3930 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3933 if (n < rank + corank - 1)
3935 gfc_init_se (&se, NULL);
3936 gcc_assert (ubound);
3937 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3938 gfc_add_block_to_block (pblock, &se.pre);
3939 gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3943 /* The stride is the number of elements in the array, so multiply by the
3944 size of an element to get the total size. */
3945 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3946 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3947 fold_convert (gfc_array_index_type, tmp));
3949 if (poffset != NULL)
3951 offset = gfc_evaluate_now (offset, pblock);
3955 if (integer_zerop (or_expr))
3957 if (integer_onep (or_expr))
3958 return gfc_index_zero_node;
3960 var = gfc_create_var (TREE_TYPE (size), "size");
3961 gfc_start_block (&thenblock);
3962 gfc_add_modify (&thenblock, var, gfc_index_zero_node);
3963 thencase = gfc_finish_block (&thenblock);
3965 gfc_start_block (&elseblock);
3966 gfc_add_modify (&elseblock, var, size);
3967 elsecase = gfc_finish_block (&elseblock);
3969 tmp = gfc_evaluate_now (or_expr, pblock);
3970 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3971 gfc_add_expr_to_block (pblock, tmp);
3977 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3978 the work for an ALLOCATE statement. */
3982 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3990 gfc_ref *ref, *prev_ref = NULL;
3991 bool allocatable_array, coarray;
3995 /* Find the last reference in the chain. */
3996 while (ref && ref->next != NULL)
3998 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
3999 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4004 if (ref == NULL || ref->type != REF_ARRAY)
4009 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4010 coarray = expr->symtree->n.sym->attr.codimension;
4014 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4015 coarray = prev_ref->u.c.component->attr.codimension;
4018 /* Return if this is a scalar coarray. */
4019 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4020 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4022 gcc_assert (coarray);
4026 /* Figure out the size of the array. */
4027 switch (ref->u.ar.type)
4033 upper = ref->u.ar.start;
4039 lower = ref->u.ar.start;
4040 upper = ref->u.ar.end;
4044 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4046 lower = ref->u.ar.as->lower;
4047 upper = ref->u.ar.as->upper;
4055 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4056 ref->u.ar.as->corank, &offset, lower, upper,
4059 /* Allocate memory to store the data. */
4060 pointer = gfc_conv_descriptor_data_get (se->expr);
4061 STRIP_NOPS (pointer);
4063 /* The allocate_array variants take the old pointer as first argument. */
4064 if (allocatable_array)
4065 tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
4067 tmp = gfc_allocate_with_status (&se->pre, size, pstat);
4068 tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
4069 gfc_add_expr_to_block (&se->pre, tmp);
4071 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4073 if (expr->ts.type == BT_DERIVED
4074 && expr->ts.u.derived->attr.alloc_comp)
4076 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4077 ref->u.ar.as->rank);
4078 gfc_add_expr_to_block (&se->pre, tmp);
4085 /* Deallocate an array variable. Also used when an allocated variable goes
4090 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4096 gfc_start_block (&block);
4097 /* Get a pointer to the data. */
4098 var = gfc_conv_descriptor_data_get (descriptor);
4101 /* Parameter is the address of the data component. */
4102 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4103 gfc_add_expr_to_block (&block, tmp);
4105 /* Zero the data pointer. */
4106 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4107 var, build_int_cst (TREE_TYPE (var), 0));
4108 gfc_add_expr_to_block (&block, tmp);
4110 return gfc_finish_block (&block);
4114 /* Create an array constructor from an initialization expression.
4115 We assume the frontend already did any expansions and conversions. */
4118 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4124 unsigned HOST_WIDE_INT lo;
4126 VEC(constructor_elt,gc) *v = NULL;
4128 switch (expr->expr_type)
4131 case EXPR_STRUCTURE:
4132 /* A single scalar or derived type value. Create an array with all
4133 elements equal to that value. */
4134 gfc_init_se (&se, NULL);
4136 if (expr->expr_type == EXPR_CONSTANT)
4137 gfc_conv_constant (&se, expr);
4139 gfc_conv_structure (&se, expr, 1);
4141 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4142 gcc_assert (tmp && INTEGER_CST_P (tmp));
4143 hi = TREE_INT_CST_HIGH (tmp);
4144 lo = TREE_INT_CST_LOW (tmp);
4148 /* This will probably eat buckets of memory for large arrays. */
4149 while (hi != 0 || lo != 0)
4151 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4159 /* Create a vector of all the elements. */
4160 for (c = gfc_constructor_first (expr->value.constructor);
4161 c; c = gfc_constructor_next (c))
4165 /* Problems occur when we get something like
4166 integer :: a(lots) = (/(i, i=1, lots)/) */
4167 gfc_fatal_error ("The number of elements in the array constructor "
4168 "at %L requires an increase of the allowed %d "
4169 "upper limit. See -fmax-array-constructor "
4170 "option", &expr->where,
4171 gfc_option.flag_max_array_constructor);
4174 if (mpz_cmp_si (c->offset, 0) != 0)
4175 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4179 gfc_init_se (&se, NULL);
4180 switch (c->expr->expr_type)
4183 gfc_conv_constant (&se, c->expr);
4184 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4187 case EXPR_STRUCTURE:
4188 gfc_conv_structure (&se, c->expr, 1);
4189 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4194 /* Catch those occasional beasts that do not simplify
4195 for one reason or another, assuming that if they are
4196 standard defying the frontend will catch them. */
4197 gfc_conv_expr (&se, c->expr);
4198 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4205 return gfc_build_null_descriptor (type);
4211 /* Create a constructor from the list of elements. */
4212 tmp = build_constructor (type, v);
4213 TREE_CONSTANT (tmp) = 1;
4218 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4219 returns the size (in elements) of the array. */
4222 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4223 stmtblock_t * pblock)
4238 size = gfc_index_one_node;
4239 offset = gfc_index_zero_node;
4240 for (dim = 0; dim < as->rank; dim++)
4242 /* Evaluate non-constant array bound expressions. */
4243 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4244 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4246 gfc_init_se (&se, NULL);
4247 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4248 gfc_add_block_to_block (pblock, &se.pre);
4249 gfc_add_modify (pblock, lbound, se.expr);
4251 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4252 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4254 gfc_init_se (&se, NULL);
4255 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4256 gfc_add_block_to_block (pblock, &se.pre);
4257 gfc_add_modify (pblock, ubound, se.expr);
4259 /* The offset of this dimension. offset = offset - lbound * stride. */
4260 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
4261 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4263 /* The size of this dimension, and the stride of the next. */
4264 if (dim + 1 < as->rank)
4265 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4267 stride = GFC_TYPE_ARRAY_SIZE (type);
4269 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4271 /* Calculate stride = size * (ubound + 1 - lbound). */
4272 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4273 gfc_index_one_node, lbound);
4274 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
4275 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
4277 gfc_add_modify (pblock, stride, tmp);
4279 stride = gfc_evaluate_now (tmp, pblock);
4281 /* Make sure that negative size arrays are translated
4282 to being zero size. */
4283 tmp = fold_build2 (GE_EXPR, boolean_type_node,
4284 stride, gfc_index_zero_node);
4285 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4286 stride, gfc_index_zero_node);
4287 gfc_add_modify (pblock, stride, tmp);
4293 gfc_trans_vla_type_sizes (sym, pblock);
4300 /* Generate code to initialize/allocate an array variable. */
4303 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4304 gfc_wrapped_block * block)
4313 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4315 /* Do nothing for USEd variables. */
4316 if (sym->attr.use_assoc)
4319 type = TREE_TYPE (decl);
4320 gcc_assert (GFC_ARRAY_TYPE_P (type));
4321 onstack = TREE_CODE (type) != POINTER_TYPE;
4323 gfc_start_block (&init);
4325 /* Evaluate character string length. */
4326 if (sym->ts.type == BT_CHARACTER
4327 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4329 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4331 gfc_trans_vla_type_sizes (sym, &init);
4333 /* Emit a DECL_EXPR for this variable, which will cause the
4334 gimplifier to allocate storage, and all that good stuff. */
4335 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4336 gfc_add_expr_to_block (&init, tmp);
4341 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4345 type = TREE_TYPE (type);
4347 gcc_assert (!sym->attr.use_assoc);
4348 gcc_assert (!TREE_STATIC (decl));
4349 gcc_assert (!sym->module);
4351 if (sym->ts.type == BT_CHARACTER
4352 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4353 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4355 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4357 /* Don't actually allocate space for Cray Pointees. */
4358 if (sym->attr.cray_pointee)
4360 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4361 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4363 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4367 /* The size is the number of elements in the array, so multiply by the
4368 size of an element to get the total size. */
4369 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4370 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
4371 fold_convert (gfc_array_index_type, tmp));
4373 /* Allocate memory to hold the data. */
4374 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4375 gfc_add_modify (&init, decl, tmp);
4377 /* Set offset of the array. */
4378 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4379 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4381 /* Automatic arrays should not have initializers. */
4382 gcc_assert (!sym->value);
4384 /* Free the temporary. */
4385 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4387 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4391 /* Generate entry and exit code for g77 calling convention arrays. */
4394 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4404 gfc_get_backend_locus (&loc);
4405 gfc_set_backend_locus (&sym->declared_at);
4407 /* Descriptor type. */
4408 parm = sym->backend_decl;
4409 type = TREE_TYPE (parm);
4410 gcc_assert (GFC_ARRAY_TYPE_P (type));
4412 gfc_start_block (&init);
4414 if (sym->ts.type == BT_CHARACTER
4415 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4416 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4418 /* Evaluate the bounds of the array. */
4419 gfc_trans_array_bounds (type, sym, &offset, &init);
4421 /* Set the offset. */
4422 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4423 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4425 /* Set the pointer itself if we aren't using the parameter directly. */
4426 if (TREE_CODE (parm) != PARM_DECL)
4428 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4429 gfc_add_modify (&init, parm, tmp);
4431 stmt = gfc_finish_block (&init);
4433 gfc_set_backend_locus (&loc);
4435 /* Add the initialization code to the start of the function. */
4437 if (sym->attr.optional || sym->attr.not_always_present)
4439 tmp = gfc_conv_expr_present (sym);
4440 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4443 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4447 /* Modify the descriptor of an array parameter so that it has the
4448 correct lower bound. Also move the upper bound accordingly.
4449 If the array is not packed, it will be copied into a temporary.
4450 For each dimension we set the new lower and upper bounds. Then we copy the
4451 stride and calculate the offset for this dimension. We also work out
4452 what the stride of a packed array would be, and see it the two match.
4453 If the array need repacking, we set the stride to the values we just
4454 calculated, recalculate the offset and copy the array data.
4455 Code is also added to copy the data back at the end of the function.
4459 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4460 gfc_wrapped_block * block)
4467 tree stmtInit, stmtCleanup;
4474 tree stride, stride2;
4484 /* Do nothing for pointer and allocatable arrays. */
4485 if (sym->attr.pointer || sym->attr.allocatable)
4488 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4490 gfc_trans_g77_array (sym, block);
4494 gfc_get_backend_locus (&loc);
4495 gfc_set_backend_locus (&sym->declared_at);
4497 /* Descriptor type. */
4498 type = TREE_TYPE (tmpdesc);
4499 gcc_assert (GFC_ARRAY_TYPE_P (type));
4500 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4501 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4502 gfc_start_block (&init);
4504 if (sym->ts.type == BT_CHARACTER
4505 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4506 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4508 checkparm = (sym->as->type == AS_EXPLICIT
4509 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4511 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4512 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
4514 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
4516 /* For non-constant shape arrays we only check if the first dimension
4517 is contiguous. Repacking higher dimensions wouldn't gain us
4518 anything as we still don't know the array stride. */
4519 partial = gfc_create_var (boolean_type_node, "partial");
4520 TREE_USED (partial) = 1;
4521 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4522 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
4523 gfc_add_modify (&init, partial, tmp);
4526 partial = NULL_TREE;
4528 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
4529 here, however I think it does the right thing. */
4532 /* Set the first stride. */
4533 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
4534 stride = gfc_evaluate_now (stride, &init);
4536 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4537 stride, gfc_index_zero_node);
4538 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
4539 gfc_index_one_node, stride);
4540 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
4541 gfc_add_modify (&init, stride, tmp);
4543 /* Allow the user to disable array repacking. */
4544 stmt_unpacked = NULL_TREE;
4548 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
4549 /* A library call to repack the array if necessary. */
4550 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4551 stmt_unpacked = build_call_expr_loc (input_location,
4552 gfor_fndecl_in_pack, 1, tmp);
4554 stride = gfc_index_one_node;
4556 if (gfc_option.warn_array_temp)
4557 gfc_warning ("Creating array temporary at %L", &loc);
4560 /* This is for the case where the array data is used directly without
4561 calling the repack function. */
4562 if (no_repack || partial != NULL_TREE)
4563 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
4565 stmt_packed = NULL_TREE;
4567 /* Assign the data pointer. */
4568 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4570 /* Don't repack unknown shape arrays when the first stride is 1. */
4571 tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
4572 partial, stmt_packed, stmt_unpacked);
4575 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
4576 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
4578 offset = gfc_index_zero_node;
4579 size = gfc_index_one_node;
4581 /* Evaluate the bounds of the array. */
4582 for (n = 0; n < sym->as->rank; n++)
4584 if (checkparm || !sym->as->upper[n])
4586 /* Get the bounds of the actual parameter. */
4587 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
4588 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
4592 dubound = NULL_TREE;
4593 dlbound = NULL_TREE;
4596 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
4597 if (!INTEGER_CST_P (lbound))
4599 gfc_init_se (&se, NULL);
4600 gfc_conv_expr_type (&se, sym->as->lower[n],
4601 gfc_array_index_type);
4602 gfc_add_block_to_block (&init, &se.pre);
4603 gfc_add_modify (&init, lbound, se.expr);
4606 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
4607 /* Set the desired upper bound. */
4608 if (sym->as->upper[n])
4610 /* We know what we want the upper bound to be. */
4611 if (!INTEGER_CST_P (ubound))
4613 gfc_init_se (&se, NULL);
4614 gfc_conv_expr_type (&se, sym->as->upper[n],
4615 gfc_array_index_type);
4616 gfc_add_block_to_block (&init, &se.pre);
4617 gfc_add_modify (&init, ubound, se.expr);
4620 /* Check the sizes match. */
4623 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
4627 temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4629 temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4630 gfc_index_one_node, temp);
4632 stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4634 stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4635 gfc_index_one_node, stride2);
4637 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
4638 asprintf (&msg, "Dimension %d of array '%s' has extent "
4639 "%%ld instead of %%ld", n+1, sym->name);
4641 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
4642 fold_convert (long_integer_type_node, temp),
4643 fold_convert (long_integer_type_node, stride2));
4650 /* For assumed shape arrays move the upper bound by the same amount
4651 as the lower bound. */
4652 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4654 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
4655 gfc_add_modify (&init, ubound, tmp);
4657 /* The offset of this dimension. offset = offset - lbound * stride. */
4658 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
4659 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
4661 /* The size of this dimension, and the stride of the next. */
4662 if (n + 1 < sym->as->rank)
4664 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
4666 if (no_repack || partial != NULL_TREE)
4668 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
4670 /* Figure out the stride if not a known constant. */
4671 if (!INTEGER_CST_P (stride))
4674 stmt_packed = NULL_TREE;
4677 /* Calculate stride = size * (ubound + 1 - lbound). */
4678 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4679 gfc_index_one_node, lbound);
4680 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4682 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
4687 /* Assign the stride. */
4688 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
4689 tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
4690 stmt_unpacked, stmt_packed);
4692 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
4693 gfc_add_modify (&init, stride, tmp);
4698 stride = GFC_TYPE_ARRAY_SIZE (type);
4700 if (stride && !INTEGER_CST_P (stride))
4702 /* Calculate size = stride * (ubound + 1 - lbound). */
4703 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4704 gfc_index_one_node, lbound);
4705 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4707 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4708 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
4709 gfc_add_modify (&init, stride, tmp);
4714 /* Set the offset. */
4715 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4716 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4718 gfc_trans_vla_type_sizes (sym, &init);
4720 stmtInit = gfc_finish_block (&init);
4722 /* Only do the entry/initialization code if the arg is present. */
4723 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4724 optional_arg = (sym->attr.optional
4725 || (sym->ns->proc_name->attr.entry_master
4726 && sym->attr.dummy));
4729 tmp = gfc_conv_expr_present (sym);
4730 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
4731 build_empty_stmt (input_location));
4736 stmtCleanup = NULL_TREE;
4739 stmtblock_t cleanup;
4740 gfc_start_block (&cleanup);
4742 if (sym->attr.intent != INTENT_IN)
4744 /* Copy the data back. */
4745 tmp = build_call_expr_loc (input_location,
4746 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
4747 gfc_add_expr_to_block (&cleanup, tmp);
4750 /* Free the temporary. */
4751 tmp = gfc_call_free (tmpdesc);
4752 gfc_add_expr_to_block (&cleanup, tmp);
4754 stmtCleanup = gfc_finish_block (&cleanup);
4756 /* Only do the cleanup if the array was repacked. */
4757 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
4758 tmp = gfc_conv_descriptor_data_get (tmp);
4759 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
4760 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4761 build_empty_stmt (input_location));
4765 tmp = gfc_conv_expr_present (sym);
4766 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
4767 build_empty_stmt (input_location));
4771 /* We don't need to free any memory allocated by internal_pack as it will
4772 be freed at the end of the function by pop_context. */
4773 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
4777 /* Calculate the overall offset, including subreferences. */
4779 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
4780 bool subref, gfc_expr *expr)
4790 /* If offset is NULL and this is not a subreferenced array, there is
4792 if (offset == NULL_TREE)
4795 offset = gfc_index_zero_node;
4800 tmp = gfc_conv_array_data (desc);
4801 tmp = build_fold_indirect_ref_loc (input_location,
4803 tmp = gfc_build_array_ref (tmp, offset, NULL);
4805 /* Offset the data pointer for pointer assignments from arrays with
4806 subreferences; e.g. my_integer => my_type(:)%integer_component. */
4809 /* Go past the array reference. */
4810 for (ref = expr->ref; ref; ref = ref->next)
4811 if (ref->type == REF_ARRAY &&
4812 ref->u.ar.type != AR_ELEMENT)
4818 /* Calculate the offset for each subsequent subreference. */
4819 for (; ref; ref = ref->next)
4824 field = ref->u.c.component->backend_decl;
4825 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
4826 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4827 tmp, field, NULL_TREE);
4831 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
4832 gfc_init_se (&start, NULL);
4833 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
4834 gfc_add_block_to_block (block, &start.pre);
4835 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
4839 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
4840 && ref->u.ar.type == AR_ELEMENT);
4842 /* TODO - Add bounds checking. */
4843 stride = gfc_index_one_node;
4844 index = gfc_index_zero_node;
4845 for (n = 0; n < ref->u.ar.dimen; n++)
4850 /* Update the index. */
4851 gfc_init_se (&start, NULL);
4852 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
4853 itmp = gfc_evaluate_now (start.expr, block);
4854 gfc_init_se (&start, NULL);
4855 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
4856 jtmp = gfc_evaluate_now (start.expr, block);
4857 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
4858 itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
4859 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
4860 index = gfc_evaluate_now (index, block);
4862 /* Update the stride. */
4863 gfc_init_se (&start, NULL);
4864 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
4865 itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
4866 itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4867 gfc_index_one_node, itmp);
4868 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
4869 stride = gfc_evaluate_now (stride, block);
4872 /* Apply the index to obtain the array element. */
4873 tmp = gfc_build_array_ref (tmp, index, NULL);
4883 /* Set the target data pointer. */
4884 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4885 gfc_conv_descriptor_data_set (block, parm, offset);
4889 /* gfc_conv_expr_descriptor needs the string length an expression
4890 so that the size of the temporary can be obtained. This is done
4891 by adding up the string lengths of all the elements in the
4892 expression. Function with non-constant expressions have their
4893 string lengths mapped onto the actual arguments using the
4894 interface mapping machinery in trans-expr.c. */
4896 get_array_charlen (gfc_expr *expr, gfc_se *se)
4898 gfc_interface_mapping mapping;
4899 gfc_formal_arglist *formal;
4900 gfc_actual_arglist *arg;
4903 if (expr->ts.u.cl->length
4904 && gfc_is_constant_expr (expr->ts.u.cl->length))
4906 if (!expr->ts.u.cl->backend_decl)
4907 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4911 switch (expr->expr_type)
4914 get_array_charlen (expr->value.op.op1, se);
4916 /* For parentheses the expression ts.u.cl is identical. */
4917 if (expr->value.op.op == INTRINSIC_PARENTHESES)
4920 expr->ts.u.cl->backend_decl =
4921 gfc_create_var (gfc_charlen_type_node, "sln");
4923 if (expr->value.op.op2)
4925 get_array_charlen (expr->value.op.op2, se);
4927 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
4929 /* Add the string lengths and assign them to the expression
4930 string length backend declaration. */
4931 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4932 fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
4933 expr->value.op.op1->ts.u.cl->backend_decl,
4934 expr->value.op.op2->ts.u.cl->backend_decl));
4937 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
4938 expr->value.op.op1->ts.u.cl->backend_decl);
4942 if (expr->value.function.esym == NULL
4943 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4945 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4949 /* Map expressions involving the dummy arguments onto the actual
4950 argument expressions. */
4951 gfc_init_interface_mapping (&mapping);
4952 formal = expr->symtree->n.sym->formal;
4953 arg = expr->value.function.actual;
4955 /* Set se = NULL in the calls to the interface mapping, to suppress any
4957 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
4962 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
4965 gfc_init_se (&tse, NULL);
4967 /* Build the expression for the character length and convert it. */
4968 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
4970 gfc_add_block_to_block (&se->pre, &tse.pre);
4971 gfc_add_block_to_block (&se->post, &tse.post);
4972 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
4973 tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
4974 build_int_cst (gfc_charlen_type_node, 0));
4975 expr->ts.u.cl->backend_decl = tse.expr;
4976 gfc_free_interface_mapping (&mapping);
4980 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
4987 /* Convert an array for passing as an actual argument. Expressions and
4988 vector subscripts are evaluated and stored in a temporary, which is then
4989 passed. For whole arrays the descriptor is passed. For array sections
4990 a modified copy of the descriptor is passed, but using the original data.
4992 This function is also used for array pointer assignments, and there
4995 - se->want_pointer && !se->direct_byref
4996 EXPR is an actual argument. On exit, se->expr contains a
4997 pointer to the array descriptor.
4999 - !se->want_pointer && !se->direct_byref
5000 EXPR is an actual argument to an intrinsic function or the
5001 left-hand side of a pointer assignment. On exit, se->expr
5002 contains the descriptor for EXPR.
5004 - !se->want_pointer && se->direct_byref
5005 EXPR is the right-hand side of a pointer assignment and
5006 se->expr is the descriptor for the previously-evaluated
5007 left-hand side. The function creates an assignment from
5008 EXPR to se->expr. */
5011 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5024 bool subref_array_target = false;
5026 gcc_assert (ss != gfc_ss_terminator);
5028 /* Special case things we know we can pass easily. */
5029 switch (expr->expr_type)
5032 /* If we have a linear array section, we can pass it directly.
5033 Otherwise we need to copy it into a temporary. */
5035 /* Find the SS for the array section. */
5037 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
5038 secss = secss->next;
5040 gcc_assert (secss != gfc_ss_terminator);
5041 info = &secss->data.info;
5043 /* Get the descriptor for the array. */
5044 gfc_conv_ss_descriptor (&se->pre, secss, 0);
5045 desc = info->descriptor;
5047 subref_array_target = se->direct_byref && is_subref_array (expr);
5048 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5049 && !subref_array_target;
5053 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5055 /* Create a new descriptor if the array doesn't have one. */
5058 else if (info->ref->u.ar.type == AR_FULL)
5060 else if (se->direct_byref)
5063 full = gfc_full_array_ref_p (info->ref, NULL);
5067 if (se->direct_byref)
5069 /* Copy the descriptor for pointer assignments. */
5070 gfc_add_modify (&se->pre, se->expr, desc);
5072 /* Add any offsets from subreferences. */
5073 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5074 subref_array_target, expr);
5076 else if (se->want_pointer)
5078 /* We pass full arrays directly. This means that pointers and
5079 allocatable arrays should also work. */
5080 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5087 if (expr->ts.type == BT_CHARACTER)
5088 se->string_length = gfc_get_expr_charlen (expr);
5095 /* A transformational function return value will be a temporary
5096 array descriptor. We still need to go through the scalarizer
5097 to create the descriptor. Elemental functions ar handled as
5098 arbitrary expressions, i.e. copy to a temporary. */
5100 /* Look for the SS for this function. */
5101 while (secss != gfc_ss_terminator
5102 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
5103 secss = secss->next;
5105 if (se->direct_byref)
5107 gcc_assert (secss != gfc_ss_terminator);
5109 /* For pointer assignments pass the descriptor directly. */
5111 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5112 gfc_conv_expr (se, expr);
5116 if (secss == gfc_ss_terminator)
5118 /* Elemental function. */
5120 if (expr->ts.type == BT_CHARACTER
5121 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5122 get_array_charlen (expr, se);
5128 /* Transformational function. */
5129 info = &secss->data.info;
5135 /* Constant array constructors don't need a temporary. */
5136 if (ss->type == GFC_SS_CONSTRUCTOR
5137 && expr->ts.type != BT_CHARACTER
5138 && gfc_constant_array_constructor_p (expr->value.constructor))
5141 info = &ss->data.info;
5153 /* Something complicated. Copy it into a temporary. */
5160 gfc_init_loopinfo (&loop);
5162 /* Associate the SS with the loop. */
5163 gfc_add_ss_to_loop (&loop, ss);
5165 /* Tell the scalarizer not to bother creating loop variables, etc. */
5167 loop.array_parameter = 1;
5169 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5170 gcc_assert (!se->direct_byref);
5172 /* Setup the scalarizing loops and bounds. */
5173 gfc_conv_ss_startstride (&loop);
5177 /* Tell the scalarizer to make a temporary. */
5178 loop.temp_ss = gfc_get_ss ();
5179 loop.temp_ss->type = GFC_SS_TEMP;
5180 loop.temp_ss->next = gfc_ss_terminator;
5182 if (expr->ts.type == BT_CHARACTER
5183 && !expr->ts.u.cl->backend_decl)
5184 get_array_charlen (expr, se);
5186 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5188 if (expr->ts.type == BT_CHARACTER)
5189 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5191 loop.temp_ss->string_length = NULL;
5193 se->string_length = loop.temp_ss->string_length;
5194 loop.temp_ss->data.temp.dimen = loop.dimen;
5195 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5198 gfc_conv_loop_setup (&loop, & expr->where);
5202 /* Copy into a temporary and pass that. We don't need to copy the data
5203 back because expressions and vector subscripts must be INTENT_IN. */
5204 /* TODO: Optimize passing function return values. */
5208 /* Start the copying loops. */
5209 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5210 gfc_mark_ss_chain_used (ss, 1);
5211 gfc_start_scalarized_body (&loop, &block);
5213 /* Copy each data element. */
5214 gfc_init_se (&lse, NULL);
5215 gfc_copy_loopinfo_to_se (&lse, &loop);
5216 gfc_init_se (&rse, NULL);
5217 gfc_copy_loopinfo_to_se (&rse, &loop);
5219 lse.ss = loop.temp_ss;
5222 gfc_conv_scalarized_array_ref (&lse, NULL);
5223 if (expr->ts.type == BT_CHARACTER)
5225 gfc_conv_expr (&rse, expr);
5226 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5227 rse.expr = build_fold_indirect_ref_loc (input_location,
5231 gfc_conv_expr_val (&rse, expr);
5233 gfc_add_block_to_block (&block, &rse.pre);
5234 gfc_add_block_to_block (&block, &lse.pre);
5236 lse.string_length = rse.string_length;
5237 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5238 expr->expr_type == EXPR_VARIABLE, true);
5239 gfc_add_expr_to_block (&block, tmp);
5241 /* Finish the copying loops. */
5242 gfc_trans_scalarizing_loops (&loop, &block);
5244 desc = loop.temp_ss->data.info.descriptor;
5246 else if (expr->expr_type == EXPR_FUNCTION)
5248 desc = info->descriptor;
5249 se->string_length = ss->string_length;
5253 /* We pass sections without copying to a temporary. Make a new
5254 descriptor and point it at the section we want. The loop variable
5255 limits will be the limits of the section.
5256 A function may decide to repack the array to speed up access, but
5257 we're not bothered about that here. */
5266 /* Set the string_length for a character array. */
5267 if (expr->ts.type == BT_CHARACTER)
5268 se->string_length = gfc_get_expr_charlen (expr);
5270 desc = info->descriptor;
5271 gcc_assert (secss && secss != gfc_ss_terminator);
5272 if (se->direct_byref)
5274 /* For pointer assignments we fill in the destination. */
5276 parmtype = TREE_TYPE (parm);
5280 /* Otherwise make a new one. */
5281 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5282 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5283 loop.from, loop.to, 0,
5284 GFC_ARRAY_UNKNOWN, false);
5285 parm = gfc_create_var (parmtype, "parm");
5288 offset = gfc_index_zero_node;
5291 /* The following can be somewhat confusing. We have two
5292 descriptors, a new one and the original array.
5293 {parm, parmtype, dim} refer to the new one.
5294 {desc, type, n, secss, loop} refer to the original, which maybe
5295 a descriptorless array.
5296 The bounds of the scalarization are the bounds of the section.
5297 We don't have to worry about numeric overflows when calculating
5298 the offsets because all elements are within the array data. */
5300 /* Set the dtype. */
5301 tmp = gfc_conv_descriptor_dtype (parm);
5302 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5304 /* Set offset for assignments to pointer only to zero if it is not
5306 if (se->direct_byref
5307 && info->ref && info->ref->u.ar.type != AR_FULL)
5308 base = gfc_index_zero_node;
5309 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5310 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5314 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5315 for (n = 0; n < ndim; n++)
5317 stride = gfc_conv_array_stride (desc, n);
5319 /* Work out the offset. */
5321 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5323 gcc_assert (info->subscript[n]
5324 && info->subscript[n]->type == GFC_SS_SCALAR);
5325 start = info->subscript[n]->data.scalar.expr;
5329 /* Check we haven't somehow got out of sync. */
5330 gcc_assert (info->dim[dim] == n);
5332 /* Evaluate and remember the start of the section. */
5333 start = info->start[n];
5334 stride = gfc_evaluate_now (stride, &loop.pre);
5337 tmp = gfc_conv_array_lbound (desc, n);
5338 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
5340 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
5341 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
5344 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5346 /* For elemental dimensions, we only need the offset. */
5350 /* Vector subscripts need copying and are handled elsewhere. */
5352 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5354 /* Set the new lower bound. */
5355 from = loop.from[dim];
5358 /* If we have an array section or are assigning make sure that
5359 the lower bound is 1. References to the full
5360 array should otherwise keep the original bounds. */
5362 || info->ref->u.ar.type != AR_FULL)
5363 && !integer_onep (from))
5365 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5366 gfc_index_one_node, from);
5367 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
5368 from = gfc_index_one_node;
5370 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5371 gfc_rank_cst[dim], from);
5373 /* Set the new upper bound. */
5374 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5375 gfc_rank_cst[dim], to);
5377 /* Multiply the stride by the section stride to get the
5379 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
5380 stride, info->stride[n]);
5382 if (se->direct_byref
5384 && info->ref->u.ar.type != AR_FULL)
5386 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5389 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5391 tmp = gfc_conv_array_lbound (desc, n);
5392 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
5393 tmp, loop.from[dim]);
5394 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
5395 tmp, gfc_conv_array_stride (desc, n));
5396 base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
5400 /* Store the new stride. */
5401 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5402 gfc_rank_cst[dim], stride);
5407 if (se->data_not_needed)
5408 gfc_conv_descriptor_data_set (&loop.pre, parm,
5409 gfc_index_zero_node);
5411 /* Point the data pointer at the 1st element in the section. */
5412 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5413 subref_array_target, expr);
5415 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5416 && !se->data_not_needed)
5418 /* Set the offset. */
5419 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
5423 /* Only the callee knows what the correct offset it, so just set
5425 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
5430 if (!se->direct_byref)
5432 /* Get a pointer to the new descriptor. */
5433 if (se->want_pointer)
5434 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5439 gfc_add_block_to_block (&se->pre, &loop.pre);
5440 gfc_add_block_to_block (&se->post, &loop.post);
5442 /* Cleanup the scalarizer. */
5443 gfc_cleanup_loop (&loop);
5446 /* Helper function for gfc_conv_array_parameter if array size needs to be
5450 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
5453 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5454 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
5455 else if (expr->rank > 1)
5456 *size = build_call_expr_loc (input_location,
5457 gfor_fndecl_size0, 1,
5458 gfc_build_addr_expr (NULL, desc));
5461 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
5462 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
5464 *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
5465 *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
5466 gfc_index_one_node);
5467 *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
5468 gfc_index_zero_node);
5470 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
5471 *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
5472 fold_convert (gfc_array_index_type, elem));
5475 /* Convert an array for passing as an actual parameter. */
5476 /* TODO: Optimize passing g77 arrays. */
5479 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
5480 const gfc_symbol *fsym, const char *proc_name,
5485 tree tmp = NULL_TREE;
5487 tree parent = DECL_CONTEXT (current_function_decl);
5488 bool full_array_var;
5489 bool this_array_result;
5492 bool array_constructor;
5493 bool good_allocatable;
5494 bool ultimate_ptr_comp;
5495 bool ultimate_alloc_comp;
5500 ultimate_ptr_comp = false;
5501 ultimate_alloc_comp = false;
5503 for (ref = expr->ref; ref; ref = ref->next)
5505 if (ref->next == NULL)
5508 if (ref->type == REF_COMPONENT)
5510 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
5511 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
5515 full_array_var = false;
5518 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
5519 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
5521 sym = full_array_var ? expr->symtree->n.sym : NULL;
5523 /* The symbol should have an array specification. */
5524 gcc_assert (!sym || sym->as || ref->u.ar.as);
5526 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
5528 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
5529 expr->ts.u.cl->backend_decl = tmp;
5530 se->string_length = tmp;
5533 /* Is this the result of the enclosing procedure? */
5534 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
5535 if (this_array_result
5536 && (sym->backend_decl != current_function_decl)
5537 && (sym->backend_decl != parent))
5538 this_array_result = false;
5540 /* Passing address of the array if it is not pointer or assumed-shape. */
5541 if (full_array_var && g77 && !this_array_result)
5543 tmp = gfc_get_symbol_decl (sym);
5545 if (sym->ts.type == BT_CHARACTER)
5546 se->string_length = sym->ts.u.cl->backend_decl;
5548 if (sym->ts.type == BT_DERIVED)
5550 gfc_conv_expr_descriptor (se, expr, ss);
5551 se->expr = gfc_conv_array_data (se->expr);
5555 if (!sym->attr.pointer
5557 && sym->as->type != AS_ASSUMED_SHAPE
5558 && !sym->attr.allocatable)
5560 /* Some variables are declared directly, others are declared as
5561 pointers and allocated on the heap. */
5562 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
5565 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
5567 array_parameter_size (tmp, expr, size);
5571 if (sym->attr.allocatable)
5573 if (sym->attr.dummy || sym->attr.result)
5575 gfc_conv_expr_descriptor (se, expr, ss);
5579 array_parameter_size (tmp, expr, size);
5580 se->expr = gfc_conv_array_data (tmp);
5585 /* A convenient reduction in scope. */
5586 contiguous = g77 && !this_array_result && contiguous;
5588 /* There is no need to pack and unpack the array, if it is contiguous
5589 and not a deferred- or assumed-shape array, or if it is simply
5591 no_pack = ((sym && sym->as
5592 && !sym->attr.pointer
5593 && sym->as->type != AS_DEFERRED
5594 && sym->as->type != AS_ASSUMED_SHAPE)
5596 (ref && ref->u.ar.as
5597 && ref->u.ar.as->type != AS_DEFERRED
5598 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
5600 gfc_is_simply_contiguous (expr, false));
5602 no_pack = contiguous && no_pack;
5604 /* Array constructors are always contiguous and do not need packing. */
5605 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
5607 /* Same is true of contiguous sections from allocatable variables. */
5608 good_allocatable = contiguous
5610 && expr->symtree->n.sym->attr.allocatable;
5612 /* Or ultimate allocatable components. */
5613 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
5615 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
5617 gfc_conv_expr_descriptor (se, expr, ss);
5618 if (expr->ts.type == BT_CHARACTER)
5619 se->string_length = expr->ts.u.cl->backend_decl;
5621 array_parameter_size (se->expr, expr, size);
5622 se->expr = gfc_conv_array_data (se->expr);
5626 if (this_array_result)
5628 /* Result of the enclosing function. */
5629 gfc_conv_expr_descriptor (se, expr, ss);
5631 array_parameter_size (se->expr, expr, size);
5632 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5634 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
5635 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5636 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
5643 /* Every other type of array. */
5644 se->want_pointer = 1;
5645 gfc_conv_expr_descriptor (se, expr, ss);
5647 array_parameter_size (build_fold_indirect_ref_loc (input_location,
5652 /* Deallocate the allocatable components of structures that are
5654 if (expr->ts.type == BT_DERIVED
5655 && expr->ts.u.derived->attr.alloc_comp
5656 && expr->expr_type != EXPR_VARIABLE)
5658 tmp = build_fold_indirect_ref_loc (input_location,
5660 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
5661 gfc_add_expr_to_block (&se->post, tmp);
5664 if (g77 || (fsym && fsym->attr.contiguous
5665 && !gfc_is_simply_contiguous (expr, false)))
5667 tree origptr = NULL_TREE;
5671 /* For contiguous arrays, save the original value of the descriptor. */
5674 origptr = gfc_create_var (pvoid_type_node, "origptr");
5675 tmp = build_fold_indirect_ref_loc (input_location, desc);
5676 tmp = gfc_conv_array_data (tmp);
5677 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr,
5678 fold_convert (TREE_TYPE (origptr), tmp));
5679 gfc_add_expr_to_block (&se->pre, tmp);
5682 /* Repack the array. */
5683 if (gfc_option.warn_array_temp)
5686 gfc_warning ("Creating array temporary at %L for argument '%s'",
5687 &expr->where, fsym->name);
5689 gfc_warning ("Creating array temporary at %L", &expr->where);
5692 ptr = build_call_expr_loc (input_location,
5693 gfor_fndecl_in_pack, 1, desc);
5695 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5697 tmp = gfc_conv_expr_present (sym);
5698 ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
5699 fold_convert (TREE_TYPE (se->expr), ptr),
5700 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
5703 ptr = gfc_evaluate_now (ptr, &se->pre);
5705 /* Use the packed data for the actual argument, except for contiguous arrays,
5706 where the descriptor's data component is set. */
5711 tmp = build_fold_indirect_ref_loc (input_location, desc);
5712 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
5715 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5719 if (fsym && proc_name)
5720 asprintf (&msg, "An array temporary was created for argument "
5721 "'%s' of procedure '%s'", fsym->name, proc_name);
5723 asprintf (&msg, "An array temporary was created");
5725 tmp = build_fold_indirect_ref_loc (input_location,
5727 tmp = gfc_conv_array_data (tmp);
5728 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5729 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5731 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5732 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5733 gfc_conv_expr_present (sym), tmp);
5735 gfc_trans_runtime_check (false, true, tmp, &se->pre,
5740 gfc_start_block (&block);
5742 /* Copy the data back. */
5743 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
5745 tmp = build_call_expr_loc (input_location,
5746 gfor_fndecl_in_unpack, 2, desc, ptr);
5747 gfc_add_expr_to_block (&block, tmp);
5750 /* Free the temporary. */
5751 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
5752 gfc_add_expr_to_block (&block, tmp);
5754 stmt = gfc_finish_block (&block);
5756 gfc_init_block (&block);
5757 /* Only if it was repacked. This code needs to be executed before the
5758 loop cleanup code. */
5759 tmp = build_fold_indirect_ref_loc (input_location,
5761 tmp = gfc_conv_array_data (tmp);
5762 tmp = fold_build2 (NE_EXPR, boolean_type_node,
5763 fold_convert (TREE_TYPE (tmp), ptr), tmp);
5765 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
5766 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
5767 gfc_conv_expr_present (sym), tmp);
5769 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5771 gfc_add_expr_to_block (&block, tmp);
5772 gfc_add_block_to_block (&block, &se->post);
5774 gfc_init_block (&se->post);
5776 /* Reset the descriptor pointer. */
5779 tmp = build_fold_indirect_ref_loc (input_location, desc);
5780 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
5783 gfc_add_block_to_block (&se->post, &block);
5788 /* Generate code to deallocate an array, if it is allocated. */
5791 gfc_trans_dealloc_allocated (tree descriptor)
5797 gfc_start_block (&block);
5799 var = gfc_conv_descriptor_data_get (descriptor);
5802 /* Call array_deallocate with an int * present in the second argument.
5803 Although it is ignored here, it's presence ensures that arrays that
5804 are already deallocated are ignored. */
5805 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
5806 gfc_add_expr_to_block (&block, tmp);
5808 /* Zero the data pointer. */
5809 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5810 var, build_int_cst (TREE_TYPE (var), 0));
5811 gfc_add_expr_to_block (&block, tmp);
5813 return gfc_finish_block (&block);
5817 /* This helper function calculates the size in words of a full array. */
5820 get_full_array_size (stmtblock_t *block, tree decl, int rank)
5825 idx = gfc_rank_cst[rank - 1];
5826 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
5827 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
5828 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
5829 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
5830 tmp, gfc_index_one_node);
5831 tmp = gfc_evaluate_now (tmp, block);
5833 nelems = gfc_conv_descriptor_stride_get (decl, idx);
5834 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5835 return gfc_evaluate_now (tmp, block);
5839 /* Allocate dest to the same size as src, and copy src -> dest.
5840 If no_malloc is set, only the copy is done. */
5843 duplicate_allocatable(tree dest, tree src, tree type, int rank,
5853 /* If the source is null, set the destination to null. Then,
5854 allocate memory to the destination. */
5855 gfc_init_block (&block);
5859 tmp = null_pointer_node;
5860 tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
5861 gfc_add_expr_to_block (&block, tmp);
5862 null_data = gfc_finish_block (&block);
5864 gfc_init_block (&block);
5865 size = TYPE_SIZE_UNIT (type);
5868 tmp = gfc_call_malloc (&block, type, size);
5869 tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
5870 fold_convert (type, tmp));
5871 gfc_add_expr_to_block (&block, tmp);
5874 tmp = built_in_decls[BUILT_IN_MEMCPY];
5875 tmp = build_call_expr_loc (input_location, tmp, 3,
5880 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
5881 null_data = gfc_finish_block (&block);
5883 gfc_init_block (&block);
5884 nelems = get_full_array_size (&block, src, rank);
5885 tmp = fold_convert (gfc_array_index_type,
5886 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
5887 size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
5890 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
5891 tmp = gfc_call_malloc (&block, tmp, size);
5892 gfc_conv_descriptor_data_set (&block, dest, tmp);
5895 /* We know the temporary and the value will be the same length,
5896 so can use memcpy. */
5897 tmp = built_in_decls[BUILT_IN_MEMCPY];
5898 tmp = build_call_expr_loc (input_location,
5899 tmp, 3, gfc_conv_descriptor_data_get (dest),
5900 gfc_conv_descriptor_data_get (src), size);
5903 gfc_add_expr_to_block (&block, tmp);
5904 tmp = gfc_finish_block (&block);
5906 /* Null the destination if the source is null; otherwise do
5907 the allocate and copy. */
5911 null_cond = gfc_conv_descriptor_data_get (src);
5913 null_cond = convert (pvoid_type_node, null_cond);
5914 null_cond = fold_build2 (NE_EXPR, boolean_type_node,
5915 null_cond, null_pointer_node);
5916 return build3_v (COND_EXPR, null_cond, tmp, null_data);
5920 /* Allocate dest to the same size as src, and copy data src -> dest. */
5923 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
5925 return duplicate_allocatable(dest, src, type, rank, false);
5929 /* Copy data src -> dest. */
5932 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
5934 return duplicate_allocatable(dest, src, type, rank, true);
5938 /* Recursively traverse an object of derived type, generating code to
5939 deallocate, nullify or copy allocatable components. This is the work horse
5940 function for the functions named in this enum. */
5942 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
5943 COPY_ONLY_ALLOC_COMP};
5946 structure_alloc_comps (gfc_symbol * der_type, tree decl,
5947 tree dest, int rank, int purpose)
5951 stmtblock_t fnblock;
5952 stmtblock_t loopbody;
5963 tree null_cond = NULL_TREE;
5965 gfc_init_block (&fnblock);
5967 decl_type = TREE_TYPE (decl);
5969 if ((POINTER_TYPE_P (decl_type) && rank != 0)
5970 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
5972 decl = build_fold_indirect_ref_loc (input_location,
5975 /* Just in case in gets dereferenced. */
5976 decl_type = TREE_TYPE (decl);
5978 /* If this an array of derived types with allocatable components
5979 build a loop and recursively call this function. */
5980 if (TREE_CODE (decl_type) == ARRAY_TYPE
5981 || GFC_DESCRIPTOR_TYPE_P (decl_type))
5983 tmp = gfc_conv_array_data (decl);
5984 var = build_fold_indirect_ref_loc (input_location,
5987 /* Get the number of elements - 1 and set the counter. */
5988 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
5990 /* Use the descriptor for an allocatable array. Since this
5991 is a full array reference, we only need the descriptor
5992 information from dimension = rank. */
5993 tmp = get_full_array_size (&fnblock, decl, rank);
5994 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
5995 tmp, gfc_index_one_node);
5997 null_cond = gfc_conv_descriptor_data_get (decl);
5998 null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
5999 build_int_cst (TREE_TYPE (null_cond), 0));
6003 /* Otherwise use the TYPE_DOMAIN information. */
6004 tmp = array_type_nelts (decl_type);
6005 tmp = fold_convert (gfc_array_index_type, tmp);
6008 /* Remember that this is, in fact, the no. of elements - 1. */
6009 nelems = gfc_evaluate_now (tmp, &fnblock);
6010 index = gfc_create_var (gfc_array_index_type, "S");
6012 /* Build the body of the loop. */
6013 gfc_init_block (&loopbody);
6015 vref = gfc_build_array_ref (var, index, NULL);
6017 if (purpose == COPY_ALLOC_COMP)
6019 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6021 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6022 gfc_add_expr_to_block (&fnblock, tmp);
6024 tmp = build_fold_indirect_ref_loc (input_location,
6025 gfc_conv_array_data (dest));
6026 dref = gfc_build_array_ref (tmp, index, NULL);
6027 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6029 else if (purpose == COPY_ONLY_ALLOC_COMP)
6031 tmp = build_fold_indirect_ref_loc (input_location,
6032 gfc_conv_array_data (dest));
6033 dref = gfc_build_array_ref (tmp, index, NULL);
6034 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6038 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6040 gfc_add_expr_to_block (&loopbody, tmp);
6042 /* Build the loop and return. */
6043 gfc_init_loopinfo (&loop);
6045 loop.from[0] = gfc_index_zero_node;
6046 loop.loopvar[0] = index;
6047 loop.to[0] = nelems;
6048 gfc_trans_scalarizing_loops (&loop, &loopbody);
6049 gfc_add_block_to_block (&fnblock, &loop.pre);
6051 tmp = gfc_finish_block (&fnblock);
6052 if (null_cond != NULL_TREE)
6053 tmp = build3_v (COND_EXPR, null_cond, tmp,
6054 build_empty_stmt (input_location));
6059 /* Otherwise, act on the components or recursively call self to
6060 act on a chain of components. */
6061 for (c = der_type->components; c; c = c->next)
6063 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
6064 && c->ts.u.derived->attr.alloc_comp;
6065 cdecl = c->backend_decl;
6066 ctype = TREE_TYPE (cdecl);
6070 case DEALLOCATE_ALLOC_COMP:
6071 /* Do not deallocate the components of ultimate pointer
6073 if (cmp_has_alloc_comps && !c->attr.pointer)
6075 comp = fold_build3 (COMPONENT_REF, ctype,
6076 decl, cdecl, NULL_TREE);
6077 rank = c->as ? c->as->rank : 0;
6078 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6080 gfc_add_expr_to_block (&fnblock, tmp);
6083 if (c->attr.allocatable && c->attr.dimension)
6085 comp = fold_build3 (COMPONENT_REF, ctype,
6086 decl, cdecl, NULL_TREE);
6087 tmp = gfc_trans_dealloc_allocated (comp);
6088 gfc_add_expr_to_block (&fnblock, tmp);
6090 else if (c->attr.allocatable)
6092 /* Allocatable scalar components. */
6093 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6095 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6096 gfc_add_expr_to_block (&fnblock, tmp);
6098 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6099 build_int_cst (TREE_TYPE (comp), 0));
6100 gfc_add_expr_to_block (&fnblock, tmp);
6102 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6104 /* Allocatable scalar CLASS components. */
6105 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6107 /* Add reference to '$data' component. */
6108 tmp = CLASS_DATA (c)->backend_decl;
6109 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6110 comp, tmp, NULL_TREE);
6112 tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
6113 gfc_add_expr_to_block (&fnblock, tmp);
6115 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6116 build_int_cst (TREE_TYPE (comp), 0));
6117 gfc_add_expr_to_block (&fnblock, tmp);
6121 case NULLIFY_ALLOC_COMP:
6122 if (c->attr.pointer)
6124 else if (c->attr.allocatable && c->attr.dimension)
6126 comp = fold_build3 (COMPONENT_REF, ctype,
6127 decl, cdecl, NULL_TREE);
6128 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6130 else if (c->attr.allocatable)
6132 /* Allocatable scalar components. */
6133 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6134 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6135 build_int_cst (TREE_TYPE (comp), 0));
6136 gfc_add_expr_to_block (&fnblock, tmp);
6138 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6140 /* Allocatable scalar CLASS components. */
6141 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6142 /* Add reference to '$data' component. */
6143 tmp = CLASS_DATA (c)->backend_decl;
6144 comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
6145 comp, tmp, NULL_TREE);
6146 tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
6147 build_int_cst (TREE_TYPE (comp), 0));
6148 gfc_add_expr_to_block (&fnblock, tmp);
6150 else if (cmp_has_alloc_comps)
6152 comp = fold_build3 (COMPONENT_REF, ctype,
6153 decl, cdecl, NULL_TREE);
6154 rank = c->as ? c->as->rank : 0;
6155 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6157 gfc_add_expr_to_block (&fnblock, tmp);
6161 case COPY_ALLOC_COMP:
6162 if (c->attr.pointer)
6165 /* We need source and destination components. */
6166 comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
6167 dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
6168 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6170 if (c->attr.allocatable && !cmp_has_alloc_comps)
6172 rank = c->as ? c->as->rank : 0;
6173 tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
6174 gfc_add_expr_to_block (&fnblock, tmp);
6177 if (cmp_has_alloc_comps)
6179 rank = c->as ? c->as->rank : 0;
6180 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6181 gfc_add_modify (&fnblock, dcmp, tmp);
6182 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6184 gfc_add_expr_to_block (&fnblock, tmp);
6194 return gfc_finish_block (&fnblock);
6197 /* Recursively traverse an object of derived type, generating code to
6198 nullify allocatable components. */
6201 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6203 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6204 NULLIFY_ALLOC_COMP);
6208 /* Recursively traverse an object of derived type, generating code to
6209 deallocate allocatable components. */
6212 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6214 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6215 DEALLOCATE_ALLOC_COMP);
6219 /* Recursively traverse an object of derived type, generating code to
6220 copy it and its allocatable components. */
6223 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6225 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6229 /* Recursively traverse an object of derived type, generating code to
6230 copy only its allocatable components. */
6233 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6235 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6239 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
6240 Do likewise, recursively if necessary, with the allocatable components of
6244 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
6250 stmtblock_t cleanup;
6253 bool sym_has_alloc_comp;
6255 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
6256 && sym->ts.u.derived->attr.alloc_comp;
6258 /* Make sure the frontend gets these right. */
6259 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
6260 fatal_error ("Possible frontend bug: Deferred array size without pointer, "
6261 "allocatable attribute or derived type without allocatable "
6264 gfc_init_block (&init);
6266 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
6267 || TREE_CODE (sym->backend_decl) == PARM_DECL);
6269 if (sym->ts.type == BT_CHARACTER
6270 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6272 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6273 gfc_trans_vla_type_sizes (sym, &init);
6276 /* Dummy, use associated and result variables don't need anything special. */
6277 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
6279 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6283 gfc_get_backend_locus (&loc);
6284 gfc_set_backend_locus (&sym->declared_at);
6285 descriptor = sym->backend_decl;
6287 /* Although static, derived types with default initializers and
6288 allocatable components must not be nulled wholesale; instead they
6289 are treated component by component. */
6290 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
6292 /* SAVEd variables are not freed on exit. */
6293 gfc_trans_static_array_pointer (sym);
6295 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
6299 /* Get the descriptor type. */
6300 type = TREE_TYPE (sym->backend_decl);
6302 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
6305 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
6307 if (sym->value == NULL
6308 || !gfc_has_default_initializer (sym->ts.u.derived))
6310 rank = sym->as ? sym->as->rank : 0;
6311 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
6313 gfc_add_expr_to_block (&init, tmp);
6316 gfc_init_default_dt (sym, &init, false);
6319 else if (!GFC_DESCRIPTOR_TYPE_P (type))
6321 /* If the backend_decl is not a descriptor, we must have a pointer
6323 descriptor = build_fold_indirect_ref_loc (input_location,
6325 type = TREE_TYPE (descriptor);
6328 /* NULLIFY the data pointer. */
6329 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
6330 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
6332 gfc_init_block (&cleanup);
6333 gfc_set_backend_locus (&loc);
6335 /* Allocatable arrays need to be freed when they go out of scope.
6336 The allocatable components of pointers must not be touched. */
6337 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
6338 && !sym->attr.pointer && !sym->attr.save)
6341 rank = sym->as ? sym->as->rank : 0;
6342 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
6343 gfc_add_expr_to_block (&cleanup, tmp);
6346 if (sym->attr.allocatable && sym->attr.dimension
6347 && !sym->attr.save && !sym->attr.result)
6349 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
6350 gfc_add_expr_to_block (&cleanup, tmp);
6353 gfc_add_init_cleanup (block, gfc_finish_block (&init),
6354 gfc_finish_block (&cleanup));
6357 /************ Expression Walking Functions ******************/
6359 /* Walk a variable reference.
6361 Possible extension - multiple component subscripts.
6362 x(:,:) = foo%a(:)%b(:)
6364 forall (i=..., j=...)
6365 x(i,j) = foo%a(j)%b(i)
6367 This adds a fair amount of complexity because you need to deal with more
6368 than one ref. Maybe handle in a similar manner to vector subscripts.
6369 Maybe not worth the effort. */
6373 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
6380 for (ref = expr->ref; ref; ref = ref->next)
6381 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6384 for (; ref; ref = ref->next)
6386 if (ref->type == REF_SUBSTRING)
6388 newss = gfc_get_ss ();
6389 newss->type = GFC_SS_SCALAR;
6390 newss->expr = ref->u.ss.start;
6394 newss = gfc_get_ss ();
6395 newss->type = GFC_SS_SCALAR;
6396 newss->expr = ref->u.ss.end;
6401 /* We're only interested in array sections from now on. */
6402 if (ref->type != REF_ARRAY)
6407 if (ar->as->rank == 0)
6409 /* Scalar coarray. */
6416 for (n = 0; n < ar->dimen; n++)
6418 newss = gfc_get_ss ();
6419 newss->type = GFC_SS_SCALAR;
6420 newss->expr = ar->start[n];
6427 newss = gfc_get_ss ();
6428 newss->type = GFC_SS_SECTION;
6431 newss->data.info.dimen = ar->as->rank;
6432 newss->data.info.ref = ref;
6434 /* Make sure array is the same as array(:,:), this way
6435 we don't need to special case all the time. */
6436 ar->dimen = ar->as->rank;
6437 for (n = 0; n < ar->dimen; n++)
6439 newss->data.info.dim[n] = n;
6440 ar->dimen_type[n] = DIMEN_RANGE;
6442 gcc_assert (ar->start[n] == NULL);
6443 gcc_assert (ar->end[n] == NULL);
6444 gcc_assert (ar->stride[n] == NULL);
6450 newss = gfc_get_ss ();
6451 newss->type = GFC_SS_SECTION;
6454 newss->data.info.dimen = 0;
6455 newss->data.info.ref = ref;
6457 /* We add SS chains for all the subscripts in the section. */
6458 for (n = 0; n < ar->dimen; n++)
6462 switch (ar->dimen_type[n])
6465 /* Add SS for elemental (scalar) subscripts. */
6466 gcc_assert (ar->start[n]);
6467 indexss = gfc_get_ss ();
6468 indexss->type = GFC_SS_SCALAR;
6469 indexss->expr = ar->start[n];
6470 indexss->next = gfc_ss_terminator;
6471 indexss->loop_chain = gfc_ss_terminator;
6472 newss->data.info.subscript[n] = indexss;
6476 /* We don't add anything for sections, just remember this
6477 dimension for later. */
6478 newss->data.info.dim[newss->data.info.dimen] = n;
6479 newss->data.info.dimen++;
6483 /* Create a GFC_SS_VECTOR index in which we can store
6484 the vector's descriptor. */
6485 indexss = gfc_get_ss ();
6486 indexss->type = GFC_SS_VECTOR;
6487 indexss->expr = ar->start[n];
6488 indexss->next = gfc_ss_terminator;
6489 indexss->loop_chain = gfc_ss_terminator;
6490 newss->data.info.subscript[n] = indexss;
6491 newss->data.info.dim[newss->data.info.dimen] = n;
6492 newss->data.info.dimen++;
6496 /* We should know what sort of section it is by now. */
6500 /* We should have at least one non-elemental dimension. */
6501 gcc_assert (newss->data.info.dimen > 0);
6506 /* We should know what sort of section it is by now. */
6515 /* Walk an expression operator. If only one operand of a binary expression is
6516 scalar, we must also add the scalar term to the SS chain. */
6519 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
6525 head = gfc_walk_subexpr (ss, expr->value.op.op1);
6526 if (expr->value.op.op2 == NULL)
6529 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6531 /* All operands are scalar. Pass back and let the caller deal with it. */
6535 /* All operands require scalarization. */
6536 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6539 /* One of the operands needs scalarization, the other is scalar.
6540 Create a gfc_ss for the scalar expression. */
6541 newss = gfc_get_ss ();
6542 newss->type = GFC_SS_SCALAR;
6545 /* First operand is scalar. We build the chain in reverse order, so
6546 add the scalar SS after the second operand. */
6548 while (head && head->next != ss)
6550 /* Check we haven't somehow broken the chain. */
6554 newss->expr = expr->value.op.op1;
6556 else /* head2 == head */
6558 gcc_assert (head2 == head);
6559 /* Second operand is scalar. */
6560 newss->next = head2;
6562 newss->expr = expr->value.op.op2;
6569 /* Reverse a SS chain. */
6572 gfc_reverse_ss (gfc_ss * ss)
6577 gcc_assert (ss != NULL);
6579 head = gfc_ss_terminator;
6580 while (ss != gfc_ss_terminator)
6583 /* Check we didn't somehow break the chain. */
6584 gcc_assert (next != NULL);
6594 /* Walk the arguments of an elemental function. */
6597 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
6605 head = gfc_ss_terminator;
6608 for (; arg; arg = arg->next)
6613 newss = gfc_walk_subexpr (head, arg->expr);
6616 /* Scalar argument. */
6617 newss = gfc_get_ss ();
6619 newss->expr = arg->expr;
6629 while (tail->next != gfc_ss_terminator)
6636 /* If all the arguments are scalar we don't need the argument SS. */
6637 gfc_free_ss_chain (head);
6642 /* Add it onto the existing chain. */
6648 /* Walk a function call. Scalar functions are passed back, and taken out of
6649 scalarization loops. For elemental functions we walk their arguments.
6650 The result of functions returning arrays is stored in a temporary outside
6651 the loop, so that the function is only called once. Hence we do not need
6652 to walk their arguments. */
6655 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
6658 gfc_intrinsic_sym *isym;
6660 gfc_component *comp = NULL;
6662 isym = expr->value.function.isym;
6664 /* Handle intrinsic functions separately. */
6666 return gfc_walk_intrinsic_function (ss, expr, isym);
6668 sym = expr->value.function.esym;
6670 sym = expr->symtree->n.sym;
6672 /* A function that returns arrays. */
6673 gfc_is_proc_ptr_comp (expr, &comp);
6674 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
6675 || (comp && comp->attr.dimension))
6677 newss = gfc_get_ss ();
6678 newss->type = GFC_SS_FUNCTION;
6681 newss->data.info.dimen = expr->rank;
6685 /* Walk the parameters of an elemental function. For now we always pass
6687 if (sym->attr.elemental)
6688 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6691 /* Scalar functions are OK as these are evaluated outside the scalarization
6692 loop. Pass back and let the caller deal with it. */
6697 /* An array temporary is constructed for array constructors. */
6700 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
6705 newss = gfc_get_ss ();
6706 newss->type = GFC_SS_CONSTRUCTOR;
6709 newss->data.info.dimen = expr->rank;
6710 for (n = 0; n < expr->rank; n++)
6711 newss->data.info.dim[n] = n;
6717 /* Walk an expression. Add walked expressions to the head of the SS chain.
6718 A wholly scalar expression will not be added. */
6721 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
6725 switch (expr->expr_type)
6728 head = gfc_walk_variable_expr (ss, expr);
6732 head = gfc_walk_op_expr (ss, expr);
6736 head = gfc_walk_function_expr (ss, expr);
6741 case EXPR_STRUCTURE:
6742 /* Pass back and let the caller deal with it. */
6746 head = gfc_walk_array_constructor (ss, expr);
6749 case EXPR_SUBSTRING:
6750 /* Pass back and let the caller deal with it. */
6754 internal_error ("bad expression type during walk (%d)",
6761 /* Entry point for expression walking.
6762 A return value equal to the passed chain means this is
6763 a scalar expression. It is up to the caller to take whatever action is
6764 necessary to translate these. */
6767 gfc_walk_expr (gfc_expr * expr)
6771 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
6772 return gfc_reverse_ss (res);