1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
85 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
88 #include "constructor.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var;
100 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 gfc_array_dataptr_type (tree desc)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
132 #define CAF_TOKEN_FIELD 4
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
172 type = TREE_TYPE (desc);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
175 field = TYPE_FIELDS (type);
176 gcc_assert (DATA_FIELD == 0);
178 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
200 return gfc_build_addr_expr (NULL_TREE, t);
204 gfc_conv_descriptor_offset (tree desc)
209 type = TREE_TYPE (desc);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
212 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
213 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
215 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
216 desc, field, NULL_TREE);
220 gfc_conv_descriptor_offset_get (tree desc)
222 return gfc_conv_descriptor_offset (desc);
226 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
229 tree t = gfc_conv_descriptor_offset (desc);
230 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
235 gfc_conv_descriptor_dtype (tree desc)
240 type = TREE_TYPE (desc);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
243 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
244 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
246 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
247 desc, field, NULL_TREE);
251 gfc_conv_descriptor_dimension (tree desc, tree dim)
257 type = TREE_TYPE (desc);
258 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
260 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
261 gcc_assert (field != NULL_TREE
262 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
263 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
265 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
266 desc, field, NULL_TREE);
267 tmp = gfc_build_array_ref (tmp, dim, NULL);
273 gfc_conv_descriptor_token (tree desc)
278 type = TREE_TYPE (desc);
279 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
280 gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
281 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
282 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
285 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
286 desc, field, NULL_TREE);
291 gfc_conv_descriptor_stride (tree desc, tree dim)
296 tmp = gfc_conv_descriptor_dimension (desc, dim);
297 field = TYPE_FIELDS (TREE_TYPE (tmp));
298 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
299 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
301 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
302 tmp, field, NULL_TREE);
307 gfc_conv_descriptor_stride_get (tree desc, tree dim)
309 tree type = TREE_TYPE (desc);
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 if (integer_zerop (dim)
312 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
313 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
314 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
315 return gfc_index_one_node;
317 return gfc_conv_descriptor_stride (desc, dim);
321 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
322 tree dim, tree value)
324 tree t = gfc_conv_descriptor_stride (desc, dim);
325 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
329 gfc_conv_descriptor_lbound (tree desc, tree dim)
334 tmp = gfc_conv_descriptor_dimension (desc, dim);
335 field = TYPE_FIELDS (TREE_TYPE (tmp));
336 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
337 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
339 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
340 tmp, field, NULL_TREE);
345 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
347 return gfc_conv_descriptor_lbound (desc, dim);
351 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
352 tree dim, tree value)
354 tree t = gfc_conv_descriptor_lbound (desc, dim);
355 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
359 gfc_conv_descriptor_ubound (tree desc, tree dim)
364 tmp = gfc_conv_descriptor_dimension (desc, dim);
365 field = TYPE_FIELDS (TREE_TYPE (tmp));
366 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
367 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
369 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
370 tmp, field, NULL_TREE);
375 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
377 return gfc_conv_descriptor_ubound (desc, dim);
381 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
382 tree dim, tree value)
384 tree t = gfc_conv_descriptor_ubound (desc, dim);
385 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
388 /* Build a null array descriptor constructor. */
391 gfc_build_null_descriptor (tree type)
396 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
397 gcc_assert (DATA_FIELD == 0);
398 field = TYPE_FIELDS (type);
400 /* Set a NULL data pointer. */
401 tmp = build_constructor_single (type, field, null_pointer_node);
402 TREE_CONSTANT (tmp) = 1;
403 /* All other fields are ignored. */
409 /* Modify a descriptor such that the lbound of a given dimension is the value
410 specified. This also updates ubound and offset accordingly. */
413 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
414 int dim, tree new_lbound)
416 tree offs, ubound, lbound, stride;
417 tree diff, offs_diff;
419 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
421 offs = gfc_conv_descriptor_offset_get (desc);
422 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
423 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
424 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
426 /* Get difference (new - old) by which to shift stuff. */
427 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
430 /* Shift ubound and offset accordingly. This has to be done before
431 updating the lbound, as they depend on the lbound expression! */
432 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
434 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
435 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
437 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
439 gfc_conv_descriptor_offset_set (block, desc, offs);
441 /* Finally set lbound to value we want. */
442 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
446 /* Cleanup those #defines. */
451 #undef DIMENSION_FIELD
452 #undef CAF_TOKEN_FIELD
453 #undef STRIDE_SUBFIELD
454 #undef LBOUND_SUBFIELD
455 #undef UBOUND_SUBFIELD
458 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
459 flags & 1 = Main loop body.
460 flags & 2 = temp copy loop. */
463 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
465 for (; ss != gfc_ss_terminator; ss = ss->next)
466 ss->useflags = flags;
469 static void gfc_free_ss (gfc_ss *);
472 /* Free a gfc_ss chain. */
475 gfc_free_ss_chain (gfc_ss * ss)
479 while (ss != gfc_ss_terminator)
481 gcc_assert (ss != NULL);
492 gfc_free_ss (gfc_ss * ss)
499 for (n = 0; n < ss->data.info.dimen; n++)
501 if (ss->data.info.subscript[ss->data.info.dim[n]])
502 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
514 /* Free all the SS associated with a loop. */
517 gfc_cleanup_loop (gfc_loopinfo * loop)
523 while (ss != gfc_ss_terminator)
525 gcc_assert (ss != NULL);
526 next = ss->loop_chain;
533 /* Associate a SS chain with a loop. */
536 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
540 if (head == gfc_ss_terminator)
544 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
546 if (ss->next == gfc_ss_terminator)
547 ss->loop_chain = loop->ss;
549 ss->loop_chain = ss->next;
551 gcc_assert (ss == gfc_ss_terminator);
556 /* Generate an initializer for a static pointer or allocatable array. */
559 gfc_trans_static_array_pointer (gfc_symbol * sym)
563 gcc_assert (TREE_STATIC (sym->backend_decl));
564 /* Just zero the data member. */
565 type = TREE_TYPE (sym->backend_decl);
566 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
570 /* If the bounds of SE's loop have not yet been set, see if they can be
571 determined from array spec AS, which is the array spec of a called
572 function. MAPPING maps the callee's dummy arguments to the values
573 that the caller is passing. Add any initialization and finalization
577 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
578 gfc_se * se, gfc_array_spec * as)
586 if (as && as->type == AS_EXPLICIT)
587 for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
589 dim = se->ss->data.info.dim[n];
590 gcc_assert (dim < as->rank);
591 gcc_assert (se->loop->dimen == as->rank);
592 if (se->loop->to[n] == NULL_TREE)
594 /* Evaluate the lower bound. */
595 gfc_init_se (&tmpse, NULL);
596 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
597 gfc_add_block_to_block (&se->pre, &tmpse.pre);
598 gfc_add_block_to_block (&se->post, &tmpse.post);
599 lower = fold_convert (gfc_array_index_type, tmpse.expr);
601 if (se->loop->codimen == 0
602 || n < se->loop->dimen + se->loop->codimen - 1)
604 /* ...and the upper bound. */
605 gfc_init_se (&tmpse, NULL);
606 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
607 gfc_add_block_to_block (&se->pre, &tmpse.pre);
608 gfc_add_block_to_block (&se->post, &tmpse.post);
609 upper = fold_convert (gfc_array_index_type, tmpse.expr);
611 /* Set the upper bound of the loop to UPPER - LOWER. */
612 tmp = fold_build2_loc (input_location, MINUS_EXPR,
613 gfc_array_index_type, upper, lower);
614 tmp = gfc_evaluate_now (tmp, &se->pre);
615 se->loop->to[n] = tmp;
622 /* Generate code to allocate an array temporary, or create a variable to
623 hold the data. If size is NULL, zero the descriptor so that the
624 callee will allocate the array. If DEALLOC is true, also generate code to
625 free the array afterwards.
627 If INITIAL is not NULL, it is packed using internal_pack and the result used
628 as data instead of allocating a fresh, unitialized area of memory.
630 Initialization code is added to PRE and finalization code to POST.
631 DYNAMIC is true if the caller may want to extend the array later
632 using realloc. This prevents us from putting the array on the stack. */
635 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
636 gfc_ss_info * info, tree size, tree nelem,
637 tree initial, bool dynamic, bool dealloc)
643 desc = info->descriptor;
644 info->offset = gfc_index_zero_node;
645 if (size == NULL_TREE || integer_zerop (size))
647 /* A callee allocated array. */
648 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
653 /* Allocate the temporary. */
654 onstack = !dynamic && initial == NULL_TREE
655 && (gfc_option.flag_stack_arrays
656 || gfc_can_put_var_on_stack (size));
660 /* Make a temporary variable to hold the data. */
661 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
662 nelem, gfc_index_one_node);
663 tmp = gfc_evaluate_now (tmp, pre);
664 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
666 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
668 tmp = gfc_create_var (tmp, "A");
669 /* If we're here only because of -fstack-arrays we have to
670 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
671 if (!gfc_can_put_var_on_stack (size))
672 gfc_add_expr_to_block (pre,
673 fold_build1_loc (input_location,
674 DECL_EXPR, TREE_TYPE (tmp),
676 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
677 gfc_conv_descriptor_data_set (pre, desc, tmp);
681 /* Allocate memory to hold the data or call internal_pack. */
682 if (initial == NULL_TREE)
684 tmp = gfc_call_malloc (pre, NULL, size);
685 tmp = gfc_evaluate_now (tmp, pre);
692 stmtblock_t do_copying;
694 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
695 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
696 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
697 tmp = gfc_get_element_type (tmp);
698 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
699 packed = gfc_create_var (build_pointer_type (tmp), "data");
701 tmp = build_call_expr_loc (input_location,
702 gfor_fndecl_in_pack, 1, initial);
703 tmp = fold_convert (TREE_TYPE (packed), tmp);
704 gfc_add_modify (pre, packed, tmp);
706 tmp = build_fold_indirect_ref_loc (input_location,
708 source_data = gfc_conv_descriptor_data_get (tmp);
710 /* internal_pack may return source->data without any allocation
711 or copying if it is already packed. If that's the case, we
712 need to allocate and copy manually. */
714 gfc_start_block (&do_copying);
715 tmp = gfc_call_malloc (&do_copying, NULL, size);
716 tmp = fold_convert (TREE_TYPE (packed), tmp);
717 gfc_add_modify (&do_copying, packed, tmp);
718 tmp = gfc_build_memcpy_call (packed, source_data, size);
719 gfc_add_expr_to_block (&do_copying, tmp);
721 was_packed = fold_build2_loc (input_location, EQ_EXPR,
722 boolean_type_node, packed,
724 tmp = gfc_finish_block (&do_copying);
725 tmp = build3_v (COND_EXPR, was_packed, tmp,
726 build_empty_stmt (input_location));
727 gfc_add_expr_to_block (pre, tmp);
729 tmp = fold_convert (pvoid_type_node, packed);
732 gfc_conv_descriptor_data_set (pre, desc, tmp);
735 info->data = gfc_conv_descriptor_data_get (desc);
737 /* The offset is zero because we create temporaries with a zero
739 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
741 if (dealloc && !onstack)
743 /* Free the temporary. */
744 tmp = gfc_conv_descriptor_data_get (desc);
745 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
746 gfc_add_expr_to_block (post, tmp);
751 /* Get the array reference dimension corresponding to the given loop dimension.
752 It is different from the true array dimension given by the dim array in
753 the case of a partial array reference
754 It is different from the loop dimension in the case of a transposed array.
758 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
760 int n, array_dim, array_ref_dim;
763 array_dim = info->dim[loop_dim];
765 for (n = 0; n < info->dimen; n++)
766 if (n != loop_dim && info->dim[n] < array_dim)
769 return array_ref_dim;
773 /* Generate code to create and initialize the descriptor for a temporary
774 array. This is used for both temporaries needed by the scalarizer, and
775 functions returning arrays. Adjusts the loop variables to be
776 zero-based, and calculates the loop bounds for callee allocated arrays.
777 Allocate the array unless it's callee allocated (we have a callee
778 allocated array if 'callee_alloc' is true, or if loop->to[n] is
779 NULL_TREE for any n). Also fills in the descriptor, data and offset
780 fields of info if known. Returns the size of the array, or NULL for a
781 callee allocated array.
783 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
784 gfc_trans_allocate_array_storage.
788 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
789 gfc_loopinfo * loop, gfc_ss_info * info,
790 tree eltype, tree initial, bool dynamic,
791 bool dealloc, bool callee_alloc, locus * where)
793 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
803 memset (from, 0, sizeof (from));
804 memset (to, 0, sizeof (to));
806 gcc_assert (info->dimen > 0);
807 gcc_assert (loop->dimen == info->dimen);
809 if (gfc_option.warn_array_temp && where)
810 gfc_warning ("Creating array temporary at %L", where);
812 /* Set the lower bound to zero. */
813 for (n = 0; n < loop->dimen; n++)
817 /* Callee allocated arrays may not have a known bound yet. */
819 loop->to[n] = gfc_evaluate_now (
820 fold_build2_loc (input_location, MINUS_EXPR,
821 gfc_array_index_type,
822 loop->to[n], loop->from[n]),
824 loop->from[n] = gfc_index_zero_node;
826 /* We are constructing the temporary's descriptor based on the loop
827 dimensions. As the dimensions may be accessed in arbitrary order
828 (think of transpose) the size taken from the n'th loop may not map
829 to the n'th dimension of the array. We need to reconstruct loop infos
830 in the right order before using it to set the descriptor
832 tmp_dim = get_array_ref_dim (info, n);
833 from[tmp_dim] = loop->from[n];
834 to[tmp_dim] = loop->to[n];
836 info->delta[dim] = gfc_index_zero_node;
837 info->start[dim] = gfc_index_zero_node;
838 info->end[dim] = gfc_index_zero_node;
839 info->stride[dim] = gfc_index_one_node;
842 /* Initialize the descriptor. */
844 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
845 GFC_ARRAY_UNKNOWN, true);
846 desc = gfc_create_var (type, "atmp");
847 GFC_DECL_PACKED_ARRAY (desc) = 1;
849 info->descriptor = desc;
850 size = gfc_index_one_node;
852 /* Fill in the array dtype. */
853 tmp = gfc_conv_descriptor_dtype (desc);
854 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
857 Fill in the bounds and stride. This is a packed array, so:
860 for (n = 0; n < rank; n++)
863 delta = ubound[n] + 1 - lbound[n];
866 size = size * sizeof(element);
871 /* If there is at least one null loop->to[n], it is a callee allocated
873 for (n = 0; n < loop->dimen; n++)
874 if (loop->to[n] == NULL_TREE)
880 for (n = 0; n < loop->dimen; n++)
884 if (size == NULL_TREE)
886 /* For a callee allocated array express the loop bounds in terms
887 of the descriptor fields. */
888 tmp = fold_build2_loc (input_location,
889 MINUS_EXPR, gfc_array_index_type,
890 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
891 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
896 /* Store the stride and bound components in the descriptor. */
897 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
899 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
900 gfc_index_zero_node);
902 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
905 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
906 to[n], gfc_index_one_node);
908 /* Check whether the size for this dimension is negative. */
909 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
910 gfc_index_zero_node);
911 cond = gfc_evaluate_now (cond, pre);
916 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
917 boolean_type_node, or_expr, cond);
919 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
921 size = gfc_evaluate_now (size, pre);
923 for (n = info->dimen; n < info->dimen + info->codimen; n++)
925 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
926 gfc_index_zero_node);
927 if (n < info->dimen + info->codimen - 1)
928 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
931 /* Get the size of the array. */
933 if (size && !callee_alloc)
935 /* If or_expr is true, then the extent in at least one
936 dimension is zero and the size is set to zero. */
937 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
938 or_expr, gfc_index_zero_node, size);
941 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
943 fold_convert (gfc_array_index_type,
944 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
952 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
955 if (info->dimen > loop->temp_dim)
956 loop->temp_dim = info->dimen;
962 /* Return the number of iterations in a loop that starts at START,
963 ends at END, and has step STEP. */
966 gfc_get_iteration_count (tree start, tree end, tree step)
971 type = TREE_TYPE (step);
972 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
973 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
974 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
975 build_int_cst (type, 1));
976 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
977 build_int_cst (type, 0));
978 return fold_convert (gfc_array_index_type, tmp);
982 /* Extend the data in array DESC by EXTRA elements. */
985 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
992 if (integer_zerop (extra))
995 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
997 /* Add EXTRA to the upper bound. */
998 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1000 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1002 /* Get the value of the current data pointer. */
1003 arg0 = gfc_conv_descriptor_data_get (desc);
1005 /* Calculate the new array size. */
1006 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1007 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1008 ubound, gfc_index_one_node);
1009 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1010 fold_convert (size_type_node, tmp),
1011 fold_convert (size_type_node, size));
1013 /* Call the realloc() function. */
1014 tmp = gfc_call_realloc (pblock, arg0, arg1);
1015 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1019 /* Return true if the bounds of iterator I can only be determined
1023 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1025 return (i->start->expr_type != EXPR_CONSTANT
1026 || i->end->expr_type != EXPR_CONSTANT
1027 || i->step->expr_type != EXPR_CONSTANT);
1031 /* Split the size of constructor element EXPR into the sum of two terms,
1032 one of which can be determined at compile time and one of which must
1033 be calculated at run time. Set *SIZE to the former and return true
1034 if the latter might be nonzero. */
1037 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1039 if (expr->expr_type == EXPR_ARRAY)
1040 return gfc_get_array_constructor_size (size, expr->value.constructor);
1041 else if (expr->rank > 0)
1043 /* Calculate everything at run time. */
1044 mpz_set_ui (*size, 0);
1049 /* A single element. */
1050 mpz_set_ui (*size, 1);
1056 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1057 of array constructor C. */
1060 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1068 mpz_set_ui (*size, 0);
1073 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1076 if (i && gfc_iterator_has_dynamic_bounds (i))
1080 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1083 /* Multiply the static part of the element size by the
1084 number of iterations. */
1085 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1086 mpz_fdiv_q (val, val, i->step->value.integer);
1087 mpz_add_ui (val, val, 1);
1088 if (mpz_sgn (val) > 0)
1089 mpz_mul (len, len, val);
1091 mpz_set_ui (len, 0);
1093 mpz_add (*size, *size, len);
1102 /* Make sure offset is a variable. */
1105 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1108 /* We should have already created the offset variable. We cannot
1109 create it here because we may be in an inner scope. */
1110 gcc_assert (*offsetvar != NULL_TREE);
1111 gfc_add_modify (pblock, *offsetvar, *poffset);
1112 *poffset = *offsetvar;
1113 TREE_USED (*offsetvar) = 1;
1117 /* Variables needed for bounds-checking. */
1118 static bool first_len;
1119 static tree first_len_val;
1120 static bool typespec_chararray_ctor;
1123 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1124 tree offset, gfc_se * se, gfc_expr * expr)
1128 gfc_conv_expr (se, expr);
1130 /* Store the value. */
1131 tmp = build_fold_indirect_ref_loc (input_location,
1132 gfc_conv_descriptor_data_get (desc));
1133 tmp = gfc_build_array_ref (tmp, offset, NULL);
1135 if (expr->ts.type == BT_CHARACTER)
1137 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1140 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1141 esize = fold_convert (gfc_charlen_type_node, esize);
1142 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1143 gfc_charlen_type_node, esize,
1144 build_int_cst (gfc_charlen_type_node,
1145 gfc_character_kinds[i].bit_size / 8));
1147 gfc_conv_string_parameter (se);
1148 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1150 /* The temporary is an array of pointers. */
1151 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1152 gfc_add_modify (&se->pre, tmp, se->expr);
1156 /* The temporary is an array of string values. */
1157 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1158 /* We know the temporary and the value will be the same length,
1159 so can use memcpy. */
1160 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1161 se->string_length, se->expr, expr->ts.kind);
1163 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1167 gfc_add_modify (&se->pre, first_len_val,
1173 /* Verify that all constructor elements are of the same
1175 tree cond = fold_build2_loc (input_location, NE_EXPR,
1176 boolean_type_node, first_len_val,
1178 gfc_trans_runtime_check
1179 (true, false, cond, &se->pre, &expr->where,
1180 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1181 fold_convert (long_integer_type_node, first_len_val),
1182 fold_convert (long_integer_type_node, se->string_length));
1188 /* TODO: Should the frontend already have done this conversion? */
1189 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1190 gfc_add_modify (&se->pre, tmp, se->expr);
1193 gfc_add_block_to_block (pblock, &se->pre);
1194 gfc_add_block_to_block (pblock, &se->post);
1198 /* Add the contents of an array to the constructor. DYNAMIC is as for
1199 gfc_trans_array_constructor_value. */
1202 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1203 tree type ATTRIBUTE_UNUSED,
1204 tree desc, gfc_expr * expr,
1205 tree * poffset, tree * offsetvar,
1216 /* We need this to be a variable so we can increment it. */
1217 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1219 gfc_init_se (&se, NULL);
1221 /* Walk the array expression. */
1222 ss = gfc_walk_expr (expr);
1223 gcc_assert (ss != gfc_ss_terminator);
1225 /* Initialize the scalarizer. */
1226 gfc_init_loopinfo (&loop);
1227 gfc_add_ss_to_loop (&loop, ss);
1229 /* Initialize the loop. */
1230 gfc_conv_ss_startstride (&loop);
1231 gfc_conv_loop_setup (&loop, &expr->where);
1233 /* Make sure the constructed array has room for the new data. */
1236 /* Set SIZE to the total number of elements in the subarray. */
1237 size = gfc_index_one_node;
1238 for (n = 0; n < loop.dimen; n++)
1240 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1241 gfc_index_one_node);
1242 size = fold_build2_loc (input_location, MULT_EXPR,
1243 gfc_array_index_type, size, tmp);
1246 /* Grow the constructed array by SIZE elements. */
1247 gfc_grow_array (&loop.pre, desc, size);
1250 /* Make the loop body. */
1251 gfc_mark_ss_chain_used (ss, 1);
1252 gfc_start_scalarized_body (&loop, &body);
1253 gfc_copy_loopinfo_to_se (&se, &loop);
1256 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1257 gcc_assert (se.ss == gfc_ss_terminator);
1259 /* Increment the offset. */
1260 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1261 *poffset, gfc_index_one_node);
1262 gfc_add_modify (&body, *poffset, tmp);
1264 /* Finish the loop. */
1265 gfc_trans_scalarizing_loops (&loop, &body);
1266 gfc_add_block_to_block (&loop.pre, &loop.post);
1267 tmp = gfc_finish_block (&loop.pre);
1268 gfc_add_expr_to_block (pblock, tmp);
1270 gfc_cleanup_loop (&loop);
1274 /* Assign the values to the elements of an array constructor. DYNAMIC
1275 is true if descriptor DESC only contains enough data for the static
1276 size calculated by gfc_get_array_constructor_size. When true, memory
1277 for the dynamic parts must be allocated using realloc. */
1280 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1281 tree desc, gfc_constructor_base base,
1282 tree * poffset, tree * offsetvar,
1291 tree shadow_loopvar = NULL_TREE;
1292 gfc_saved_var saved_loopvar;
1295 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1297 /* If this is an iterator or an array, the offset must be a variable. */
1298 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1299 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1301 /* Shadowing the iterator avoids changing its value and saves us from
1302 keeping track of it. Further, it makes sure that there's always a
1303 backend-decl for the symbol, even if there wasn't one before,
1304 e.g. in the case of an iterator that appears in a specification
1305 expression in an interface mapping. */
1308 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1309 tree type = gfc_typenode_for_spec (&sym->ts);
1311 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1312 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1315 gfc_start_block (&body);
1317 if (c->expr->expr_type == EXPR_ARRAY)
1319 /* Array constructors can be nested. */
1320 gfc_trans_array_constructor_value (&body, type, desc,
1321 c->expr->value.constructor,
1322 poffset, offsetvar, dynamic);
1324 else if (c->expr->rank > 0)
1326 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1327 poffset, offsetvar, dynamic);
1331 /* This code really upsets the gimplifier so don't bother for now. */
1338 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1340 p = gfc_constructor_next (p);
1345 /* Scalar values. */
1346 gfc_init_se (&se, NULL);
1347 gfc_trans_array_ctor_element (&body, desc, *poffset,
1350 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1351 gfc_array_index_type,
1352 *poffset, gfc_index_one_node);
1356 /* Collect multiple scalar constants into a constructor. */
1357 VEC(constructor_elt,gc) *v = NULL;
1361 HOST_WIDE_INT idx = 0;
1364 /* Count the number of consecutive scalar constants. */
1365 while (p && !(p->iterator
1366 || p->expr->expr_type != EXPR_CONSTANT))
1368 gfc_init_se (&se, NULL);
1369 gfc_conv_constant (&se, p->expr);
1371 if (c->expr->ts.type != BT_CHARACTER)
1372 se.expr = fold_convert (type, se.expr);
1373 /* For constant character array constructors we build
1374 an array of pointers. */
1375 else if (POINTER_TYPE_P (type))
1376 se.expr = gfc_build_addr_expr
1377 (gfc_get_pchar_type (p->expr->ts.kind),
1380 CONSTRUCTOR_APPEND_ELT (v,
1381 build_int_cst (gfc_array_index_type,
1385 p = gfc_constructor_next (p);
1388 bound = size_int (n - 1);
1389 /* Create an array type to hold them. */
1390 tmptype = build_range_type (gfc_array_index_type,
1391 gfc_index_zero_node, bound);
1392 tmptype = build_array_type (type, tmptype);
1394 init = build_constructor (tmptype, v);
1395 TREE_CONSTANT (init) = 1;
1396 TREE_STATIC (init) = 1;
1397 /* Create a static variable to hold the data. */
1398 tmp = gfc_create_var (tmptype, "data");
1399 TREE_STATIC (tmp) = 1;
1400 TREE_CONSTANT (tmp) = 1;
1401 TREE_READONLY (tmp) = 1;
1402 DECL_INITIAL (tmp) = init;
1405 /* Use BUILTIN_MEMCPY to assign the values. */
1406 tmp = gfc_conv_descriptor_data_get (desc);
1407 tmp = build_fold_indirect_ref_loc (input_location,
1409 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1410 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1411 init = gfc_build_addr_expr (NULL_TREE, init);
1413 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1414 bound = build_int_cst (size_type_node, n * size);
1415 tmp = build_call_expr_loc (input_location,
1416 built_in_decls[BUILT_IN_MEMCPY], 3,
1418 gfc_add_expr_to_block (&body, tmp);
1420 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1421 gfc_array_index_type, *poffset,
1422 build_int_cst (gfc_array_index_type, n));
1424 if (!INTEGER_CST_P (*poffset))
1426 gfc_add_modify (&body, *offsetvar, *poffset);
1427 *poffset = *offsetvar;
1431 /* The frontend should already have done any expansions
1435 /* Pass the code as is. */
1436 tmp = gfc_finish_block (&body);
1437 gfc_add_expr_to_block (pblock, tmp);
1441 /* Build the implied do-loop. */
1442 stmtblock_t implied_do_block;
1450 loopbody = gfc_finish_block (&body);
1452 /* Create a new block that holds the implied-do loop. A temporary
1453 loop-variable is used. */
1454 gfc_start_block(&implied_do_block);
1456 /* Initialize the loop. */
1457 gfc_init_se (&se, NULL);
1458 gfc_conv_expr_val (&se, c->iterator->start);
1459 gfc_add_block_to_block (&implied_do_block, &se.pre);
1460 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1462 gfc_init_se (&se, NULL);
1463 gfc_conv_expr_val (&se, c->iterator->end);
1464 gfc_add_block_to_block (&implied_do_block, &se.pre);
1465 end = gfc_evaluate_now (se.expr, &implied_do_block);
1467 gfc_init_se (&se, NULL);
1468 gfc_conv_expr_val (&se, c->iterator->step);
1469 gfc_add_block_to_block (&implied_do_block, &se.pre);
1470 step = gfc_evaluate_now (se.expr, &implied_do_block);
1472 /* If this array expands dynamically, and the number of iterations
1473 is not constant, we won't have allocated space for the static
1474 part of C->EXPR's size. Do that now. */
1475 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1477 /* Get the number of iterations. */
1478 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1480 /* Get the static part of C->EXPR's size. */
1481 gfc_get_array_constructor_element_size (&size, c->expr);
1482 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1484 /* Grow the array by TMP * TMP2 elements. */
1485 tmp = fold_build2_loc (input_location, MULT_EXPR,
1486 gfc_array_index_type, tmp, tmp2);
1487 gfc_grow_array (&implied_do_block, desc, tmp);
1490 /* Generate the loop body. */
1491 exit_label = gfc_build_label_decl (NULL_TREE);
1492 gfc_start_block (&body);
1494 /* Generate the exit condition. Depending on the sign of
1495 the step variable we have to generate the correct
1497 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1498 step, build_int_cst (TREE_TYPE (step), 0));
1499 cond = fold_build3_loc (input_location, COND_EXPR,
1500 boolean_type_node, tmp,
1501 fold_build2_loc (input_location, GT_EXPR,
1502 boolean_type_node, shadow_loopvar, end),
1503 fold_build2_loc (input_location, LT_EXPR,
1504 boolean_type_node, shadow_loopvar, end));
1505 tmp = build1_v (GOTO_EXPR, exit_label);
1506 TREE_USED (exit_label) = 1;
1507 tmp = build3_v (COND_EXPR, cond, tmp,
1508 build_empty_stmt (input_location));
1509 gfc_add_expr_to_block (&body, tmp);
1511 /* The main loop body. */
1512 gfc_add_expr_to_block (&body, loopbody);
1514 /* Increase loop variable by step. */
1515 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1516 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1518 gfc_add_modify (&body, shadow_loopvar, tmp);
1520 /* Finish the loop. */
1521 tmp = gfc_finish_block (&body);
1522 tmp = build1_v (LOOP_EXPR, tmp);
1523 gfc_add_expr_to_block (&implied_do_block, tmp);
1525 /* Add the exit label. */
1526 tmp = build1_v (LABEL_EXPR, exit_label);
1527 gfc_add_expr_to_block (&implied_do_block, tmp);
1529 /* Finishe the implied-do loop. */
1530 tmp = gfc_finish_block(&implied_do_block);
1531 gfc_add_expr_to_block(pblock, tmp);
1533 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1540 /* A catch-all to obtain the string length for anything that is not a
1541 a substring of non-constant length, a constant, array or variable. */
1544 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1549 /* Don't bother if we already know the length is a constant. */
1550 if (*len && INTEGER_CST_P (*len))
1553 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1554 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1557 gfc_conv_const_charlen (e->ts.u.cl);
1558 *len = e->ts.u.cl->backend_decl;
1562 /* Otherwise, be brutal even if inefficient. */
1563 ss = gfc_walk_expr (e);
1564 gfc_init_se (&se, NULL);
1566 /* No function call, in case of side effects. */
1567 se.no_function_call = 1;
1568 if (ss == gfc_ss_terminator)
1569 gfc_conv_expr (&se, e);
1571 gfc_conv_expr_descriptor (&se, e, ss);
1573 /* Fix the value. */
1574 *len = gfc_evaluate_now (se.string_length, &se.pre);
1576 gfc_add_block_to_block (block, &se.pre);
1577 gfc_add_block_to_block (block, &se.post);
1579 e->ts.u.cl->backend_decl = *len;
1584 /* Figure out the string length of a variable reference expression.
1585 Used by get_array_ctor_strlen. */
1588 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1594 /* Don't bother if we already know the length is a constant. */
1595 if (*len && INTEGER_CST_P (*len))
1598 ts = &expr->symtree->n.sym->ts;
1599 for (ref = expr->ref; ref; ref = ref->next)
1604 /* Array references don't change the string length. */
1608 /* Use the length of the component. */
1609 ts = &ref->u.c.component->ts;
1613 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1614 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1616 /* Note that this might evaluate expr. */
1617 get_array_ctor_all_strlen (block, expr, len);
1620 mpz_init_set_ui (char_len, 1);
1621 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1622 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1623 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1624 *len = convert (gfc_charlen_type_node, *len);
1625 mpz_clear (char_len);
1633 *len = ts->u.cl->backend_decl;
1637 /* Figure out the string length of a character array constructor.
1638 If len is NULL, don't calculate the length; this happens for recursive calls
1639 when a sub-array-constructor is an element but not at the first position,
1640 so when we're not interested in the length.
1641 Returns TRUE if all elements are character constants. */
1644 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1651 if (gfc_constructor_first (base) == NULL)
1654 *len = build_int_cstu (gfc_charlen_type_node, 0);
1658 /* Loop over all constructor elements to find out is_const, but in len we
1659 want to store the length of the first, not the last, element. We can
1660 of course exit the loop as soon as is_const is found to be false. */
1661 for (c = gfc_constructor_first (base);
1662 c && is_const; c = gfc_constructor_next (c))
1664 switch (c->expr->expr_type)
1667 if (len && !(*len && INTEGER_CST_P (*len)))
1668 *len = build_int_cstu (gfc_charlen_type_node,
1669 c->expr->value.character.length);
1673 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1680 get_array_ctor_var_strlen (block, c->expr, len);
1686 get_array_ctor_all_strlen (block, c->expr, len);
1690 /* After the first iteration, we don't want the length modified. */
1697 /* Check whether the array constructor C consists entirely of constant
1698 elements, and if so returns the number of those elements, otherwise
1699 return zero. Note, an empty or NULL array constructor returns zero. */
1701 unsigned HOST_WIDE_INT
1702 gfc_constant_array_constructor_p (gfc_constructor_base base)
1704 unsigned HOST_WIDE_INT nelem = 0;
1706 gfc_constructor *c = gfc_constructor_first (base);
1710 || c->expr->rank > 0
1711 || c->expr->expr_type != EXPR_CONSTANT)
1713 c = gfc_constructor_next (c);
1720 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1721 and the tree type of it's elements, TYPE, return a static constant
1722 variable that is compile-time initialized. */
1725 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1727 tree tmptype, init, tmp;
1728 HOST_WIDE_INT nelem;
1733 VEC(constructor_elt,gc) *v = NULL;
1735 /* First traverse the constructor list, converting the constants
1736 to tree to build an initializer. */
1738 c = gfc_constructor_first (expr->value.constructor);
1741 gfc_init_se (&se, NULL);
1742 gfc_conv_constant (&se, c->expr);
1743 if (c->expr->ts.type != BT_CHARACTER)
1744 se.expr = fold_convert (type, se.expr);
1745 else if (POINTER_TYPE_P (type))
1746 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1748 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1750 c = gfc_constructor_next (c);
1754 /* Next determine the tree type for the array. We use the gfortran
1755 front-end's gfc_get_nodesc_array_type in order to create a suitable
1756 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1758 memset (&as, 0, sizeof (gfc_array_spec));
1760 as.rank = expr->rank;
1761 as.type = AS_EXPLICIT;
1764 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1765 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1769 for (i = 0; i < expr->rank; i++)
1771 int tmp = (int) mpz_get_si (expr->shape[i]);
1772 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1773 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1777 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1779 /* as is not needed anymore. */
1780 for (i = 0; i < as.rank + as.corank; i++)
1782 gfc_free_expr (as.lower[i]);
1783 gfc_free_expr (as.upper[i]);
1786 init = build_constructor (tmptype, v);
1788 TREE_CONSTANT (init) = 1;
1789 TREE_STATIC (init) = 1;
1791 tmp = gfc_create_var (tmptype, "A");
1792 TREE_STATIC (tmp) = 1;
1793 TREE_CONSTANT (tmp) = 1;
1794 TREE_READONLY (tmp) = 1;
1795 DECL_INITIAL (tmp) = init;
1801 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1802 This mostly initializes the scalarizer state info structure with the
1803 appropriate values to directly use the array created by the function
1804 gfc_build_constant_array_constructor. */
1807 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1808 gfc_ss * ss, tree type)
1814 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1816 info = &ss->data.info;
1818 info->descriptor = tmp;
1819 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1820 info->offset = gfc_index_zero_node;
1822 for (i = 0; i < info->dimen + info->codimen; i++)
1824 info->delta[i] = gfc_index_zero_node;
1825 info->start[i] = gfc_index_zero_node;
1826 info->end[i] = gfc_index_zero_node;
1827 info->stride[i] = gfc_index_one_node;
1831 if (info->dimen > loop->temp_dim)
1832 loop->temp_dim = info->dimen;
1835 /* Helper routine of gfc_trans_array_constructor to determine if the
1836 bounds of the loop specified by LOOP are constant and simple enough
1837 to use with gfc_trans_constant_array_constructor. Returns the
1838 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1841 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1843 tree size = gfc_index_one_node;
1847 for (i = 0; i < loop->dimen; i++)
1849 /* If the bounds aren't constant, return NULL_TREE. */
1850 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1852 if (!integer_zerop (loop->from[i]))
1854 /* Only allow nonzero "from" in one-dimensional arrays. */
1855 if (loop->dimen != 1)
1857 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1858 gfc_array_index_type,
1859 loop->to[i], loop->from[i]);
1863 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1864 tmp, gfc_index_one_node);
1865 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1873 /* Array constructors are handled by constructing a temporary, then using that
1874 within the scalarization loop. This is not optimal, but seems by far the
1878 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1880 gfc_constructor_base c;
1887 bool old_first_len, old_typespec_chararray_ctor;
1888 tree old_first_len_val;
1890 /* Save the old values for nested checking. */
1891 old_first_len = first_len;
1892 old_first_len_val = first_len_val;
1893 old_typespec_chararray_ctor = typespec_chararray_ctor;
1895 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1896 typespec was given for the array constructor. */
1897 typespec_chararray_ctor = (ss->expr->ts.u.cl
1898 && ss->expr->ts.u.cl->length_from_typespec);
1900 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1901 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1903 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1907 ss->data.info.dimen = loop->dimen;
1909 c = ss->expr->value.constructor;
1910 if (ss->expr->ts.type == BT_CHARACTER)
1914 /* get_array_ctor_strlen walks the elements of the constructor, if a
1915 typespec was given, we already know the string length and want the one
1917 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1918 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1922 const_string = false;
1923 gfc_init_se (&length_se, NULL);
1924 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1925 gfc_charlen_type_node);
1926 ss->string_length = length_se.expr;
1927 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1928 gfc_add_block_to_block (&loop->post, &length_se.post);
1931 const_string = get_array_ctor_strlen (&loop->pre, c,
1932 &ss->string_length);
1934 /* Complex character array constructors should have been taken care of
1935 and not end up here. */
1936 gcc_assert (ss->string_length);
1938 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1940 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1942 type = build_pointer_type (type);
1945 type = gfc_typenode_for_spec (&ss->expr->ts);
1947 /* See if the constructor determines the loop bounds. */
1950 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1952 /* We have a multidimensional parameter. */
1954 for (n = 0; n < ss->expr->rank; n++)
1956 loop->from[n] = gfc_index_zero_node;
1957 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1958 gfc_index_integer_kind);
1959 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1960 gfc_array_index_type,
1961 loop->to[n], gfc_index_one_node);
1965 if (loop->to[0] == NULL_TREE)
1969 /* We should have a 1-dimensional, zero-based loop. */
1970 gcc_assert (loop->dimen == 1);
1971 gcc_assert (integer_zerop (loop->from[0]));
1973 /* Split the constructor size into a static part and a dynamic part.
1974 Allocate the static size up-front and record whether the dynamic
1975 size might be nonzero. */
1977 dynamic = gfc_get_array_constructor_size (&size, c);
1978 mpz_sub_ui (size, size, 1);
1979 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1983 /* Special case constant array constructors. */
1986 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1989 tree size = constant_array_constructor_loop_size (loop);
1990 if (size && compare_tree_int (size, nelem) == 0)
1992 gfc_trans_constant_array_constructor (loop, ss, type);
1998 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2001 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
2002 type, NULL_TREE, dynamic, true, false, where);
2004 desc = ss->data.info.descriptor;
2005 offset = gfc_index_zero_node;
2006 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2007 TREE_NO_WARNING (offsetvar) = 1;
2008 TREE_USED (offsetvar) = 0;
2009 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2010 &offset, &offsetvar, dynamic);
2012 /* If the array grows dynamically, the upper bound of the loop variable
2013 is determined by the array's final upper bound. */
2016 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2017 gfc_array_index_type,
2018 offsetvar, gfc_index_one_node);
2019 tmp = gfc_evaluate_now (tmp, &loop->pre);
2020 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2021 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2022 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2027 if (TREE_USED (offsetvar))
2028 pushdecl (offsetvar);
2030 gcc_assert (INTEGER_CST_P (offset));
2033 /* Disable bound checking for now because it's probably broken. */
2034 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2041 /* Restore old values of globals. */
2042 first_len = old_first_len;
2043 first_len_val = old_first_len_val;
2044 typespec_chararray_ctor = old_typespec_chararray_ctor;
2048 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2049 called after evaluating all of INFO's vector dimensions. Go through
2050 each such vector dimension and see if we can now fill in any missing
2054 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2063 for (n = 0; n < loop->dimen + loop->codimen; n++)
2066 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2067 && loop->to[n] == NULL)
2069 /* Loop variable N indexes vector dimension DIM, and we don't
2070 yet know the upper bound of loop variable N. Set it to the
2071 difference between the vector's upper and lower bounds. */
2072 gcc_assert (loop->from[n] == gfc_index_zero_node);
2073 gcc_assert (info->subscript[dim]
2074 && info->subscript[dim]->type == GFC_SS_VECTOR);
2076 gfc_init_se (&se, NULL);
2077 desc = info->subscript[dim]->data.info.descriptor;
2078 zero = gfc_rank_cst[0];
2079 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2080 gfc_array_index_type,
2081 gfc_conv_descriptor_ubound_get (desc, zero),
2082 gfc_conv_descriptor_lbound_get (desc, zero));
2083 tmp = gfc_evaluate_now (tmp, &loop->pre);
2090 /* Add the pre and post chains for all the scalar expressions in a SS chain
2091 to loop. This is called after the loop parameters have been calculated,
2092 but before the actual scalarizing loops. */
2095 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2101 /* TODO: This can generate bad code if there are ordering dependencies,
2102 e.g., a callee allocated function and an unknown size constructor. */
2103 gcc_assert (ss != NULL);
2105 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2112 /* Scalar expression. Evaluate this now. This includes elemental
2113 dimension indices, but not array section bounds. */
2114 gfc_init_se (&se, NULL);
2115 gfc_conv_expr (&se, ss->expr);
2116 gfc_add_block_to_block (&loop->pre, &se.pre);
2118 if (ss->expr->ts.type != BT_CHARACTER)
2120 /* Move the evaluation of scalar expressions outside the
2121 scalarization loop, except for WHERE assignments. */
2123 se.expr = convert(gfc_array_index_type, se.expr);
2125 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2126 gfc_add_block_to_block (&loop->pre, &se.post);
2129 gfc_add_block_to_block (&loop->post, &se.post);
2131 ss->data.scalar.expr = se.expr;
2132 ss->string_length = se.string_length;
2135 case GFC_SS_REFERENCE:
2136 /* Scalar argument to elemental procedure. Evaluate this
2138 gfc_init_se (&se, NULL);
2139 gfc_conv_expr (&se, ss->expr);
2140 gfc_add_block_to_block (&loop->pre, &se.pre);
2141 gfc_add_block_to_block (&loop->post, &se.post);
2143 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2144 ss->string_length = se.string_length;
2147 case GFC_SS_SECTION:
2148 /* Add the expressions for scalar and vector subscripts. */
2149 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2150 if (ss->data.info.subscript[n])
2151 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2154 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2158 /* Get the vector's descriptor and store it in SS. */
2159 gfc_init_se (&se, NULL);
2160 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2161 gfc_add_block_to_block (&loop->pre, &se.pre);
2162 gfc_add_block_to_block (&loop->post, &se.post);
2163 ss->data.info.descriptor = se.expr;
2166 case GFC_SS_INTRINSIC:
2167 gfc_add_intrinsic_ss_code (loop, ss);
2170 case GFC_SS_FUNCTION:
2171 /* Array function return value. We call the function and save its
2172 result in a temporary for use inside the loop. */
2173 gfc_init_se (&se, NULL);
2176 gfc_conv_expr (&se, ss->expr);
2177 gfc_add_block_to_block (&loop->pre, &se.pre);
2178 gfc_add_block_to_block (&loop->post, &se.post);
2179 ss->string_length = se.string_length;
2182 case GFC_SS_CONSTRUCTOR:
2183 if (ss->expr->ts.type == BT_CHARACTER
2184 && ss->string_length == NULL
2185 && ss->expr->ts.u.cl
2186 && ss->expr->ts.u.cl->length)
2188 gfc_init_se (&se, NULL);
2189 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2190 gfc_charlen_type_node);
2191 ss->string_length = se.expr;
2192 gfc_add_block_to_block (&loop->pre, &se.pre);
2193 gfc_add_block_to_block (&loop->post, &se.post);
2195 gfc_trans_array_constructor (loop, ss, where);
2199 case GFC_SS_COMPONENT:
2200 /* Do nothing. These are handled elsewhere. */
2210 /* Translate expressions for the descriptor and data pointer of a SS. */
2214 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2219 /* Get the descriptor for the array to be scalarized. */
2220 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2221 gfc_init_se (&se, NULL);
2222 se.descriptor_only = 1;
2223 gfc_conv_expr_lhs (&se, ss->expr);
2224 gfc_add_block_to_block (block, &se.pre);
2225 ss->data.info.descriptor = se.expr;
2226 ss->string_length = se.string_length;
2230 /* Also the data pointer. */
2231 tmp = gfc_conv_array_data (se.expr);
2232 /* If this is a variable or address of a variable we use it directly.
2233 Otherwise we must evaluate it now to avoid breaking dependency
2234 analysis by pulling the expressions for elemental array indices
2237 || (TREE_CODE (tmp) == ADDR_EXPR
2238 && DECL_P (TREE_OPERAND (tmp, 0)))))
2239 tmp = gfc_evaluate_now (tmp, block);
2240 ss->data.info.data = tmp;
2242 tmp = gfc_conv_array_offset (se.expr);
2243 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2245 /* Make absolutely sure that the saved_offset is indeed saved
2246 so that the variable is still accessible after the loops
2248 ss->data.info.saved_offset = ss->data.info.offset;
2253 /* Initialize a gfc_loopinfo structure. */
2256 gfc_init_loopinfo (gfc_loopinfo * loop)
2260 memset (loop, 0, sizeof (gfc_loopinfo));
2261 gfc_init_block (&loop->pre);
2262 gfc_init_block (&loop->post);
2264 /* Initially scalarize in order and default to no loop reversal. */
2265 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2268 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2271 loop->ss = gfc_ss_terminator;
2275 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2279 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2285 /* Return an expression for the data pointer of an array. */
2288 gfc_conv_array_data (tree descriptor)
2292 type = TREE_TYPE (descriptor);
2293 if (GFC_ARRAY_TYPE_P (type))
2295 if (TREE_CODE (type) == POINTER_TYPE)
2299 /* Descriptorless arrays. */
2300 return gfc_build_addr_expr (NULL_TREE, descriptor);
2304 return gfc_conv_descriptor_data_get (descriptor);
2308 /* Return an expression for the base offset of an array. */
2311 gfc_conv_array_offset (tree descriptor)
2315 type = TREE_TYPE (descriptor);
2316 if (GFC_ARRAY_TYPE_P (type))
2317 return GFC_TYPE_ARRAY_OFFSET (type);
2319 return gfc_conv_descriptor_offset_get (descriptor);
2323 /* Get an expression for the array stride. */
2326 gfc_conv_array_stride (tree descriptor, int dim)
2331 type = TREE_TYPE (descriptor);
2333 /* For descriptorless arrays use the array size. */
2334 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2335 if (tmp != NULL_TREE)
2338 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2343 /* Like gfc_conv_array_stride, but for the lower bound. */
2346 gfc_conv_array_lbound (tree descriptor, int dim)
2351 type = TREE_TYPE (descriptor);
2353 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2354 if (tmp != NULL_TREE)
2357 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2362 /* Like gfc_conv_array_stride, but for the upper bound. */
2365 gfc_conv_array_ubound (tree descriptor, int dim)
2370 type = TREE_TYPE (descriptor);
2372 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2373 if (tmp != NULL_TREE)
2376 /* This should only ever happen when passing an assumed shape array
2377 as an actual parameter. The value will never be used. */
2378 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2379 return gfc_index_zero_node;
2381 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2386 /* Generate code to perform an array index bound check. */
2389 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2390 locus * where, bool check_upper)
2393 tree tmp_lo, tmp_up;
2395 const char * name = NULL;
2397 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2400 index = gfc_evaluate_now (index, &se->pre);
2402 /* We find a name for the error message. */
2404 name = se->ss->expr->symtree->name;
2406 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2407 && se->loop->ss->expr->symtree)
2408 name = se->loop->ss->expr->symtree->name;
2410 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2411 && se->loop->ss->loop_chain->expr
2412 && se->loop->ss->loop_chain->expr->symtree)
2413 name = se->loop->ss->loop_chain->expr->symtree->name;
2415 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2417 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2418 && se->loop->ss->expr->value.function.name)
2419 name = se->loop->ss->expr->value.function.name;
2421 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2422 || se->loop->ss->type == GFC_SS_SCALAR)
2423 name = "unnamed constant";
2426 if (TREE_CODE (descriptor) == VAR_DECL)
2427 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2429 /* If upper bound is present, include both bounds in the error message. */
2432 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2433 tmp_up = gfc_conv_array_ubound (descriptor, n);
2436 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2437 "outside of expected range (%%ld:%%ld)", n+1, name);
2439 asprintf (&msg, "Index '%%ld' of dimension %d "
2440 "outside of expected range (%%ld:%%ld)", n+1);
2442 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2444 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2445 fold_convert (long_integer_type_node, index),
2446 fold_convert (long_integer_type_node, tmp_lo),
2447 fold_convert (long_integer_type_node, tmp_up));
2448 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2450 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2451 fold_convert (long_integer_type_node, index),
2452 fold_convert (long_integer_type_node, tmp_lo),
2453 fold_convert (long_integer_type_node, tmp_up));
2458 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2461 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2462 "below lower bound of %%ld", n+1, name);
2464 asprintf (&msg, "Index '%%ld' of dimension %d "
2465 "below lower bound of %%ld", n+1);
2467 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2469 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2470 fold_convert (long_integer_type_node, index),
2471 fold_convert (long_integer_type_node, tmp_lo));
2479 /* Return the offset for an index. Performs bound checking for elemental
2480 dimensions. Single element references are processed separately.
2481 DIM is the array dimension, I is the loop dimension. */
2484 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2485 gfc_array_ref * ar, tree stride)
2491 /* Get the index into the array for this dimension. */
2494 gcc_assert (ar->type != AR_ELEMENT);
2495 switch (ar->dimen_type[dim])
2497 case DIMEN_THIS_IMAGE:
2501 /* Elemental dimension. */
2502 gcc_assert (info->subscript[dim]
2503 && info->subscript[dim]->type == GFC_SS_SCALAR);
2504 /* We've already translated this value outside the loop. */
2505 index = info->subscript[dim]->data.scalar.expr;
2507 index = gfc_trans_array_bound_check (se, info->descriptor,
2508 index, dim, &ar->where,
2509 ar->as->type != AS_ASSUMED_SIZE
2510 || dim < ar->dimen - 1);
2514 gcc_assert (info && se->loop);
2515 gcc_assert (info->subscript[dim]
2516 && info->subscript[dim]->type == GFC_SS_VECTOR);
2517 desc = info->subscript[dim]->data.info.descriptor;
2519 /* Get a zero-based index into the vector. */
2520 index = fold_build2_loc (input_location, MINUS_EXPR,
2521 gfc_array_index_type,
2522 se->loop->loopvar[i], se->loop->from[i]);
2524 /* Multiply the index by the stride. */
2525 index = fold_build2_loc (input_location, MULT_EXPR,
2526 gfc_array_index_type,
2527 index, gfc_conv_array_stride (desc, 0));
2529 /* Read the vector to get an index into info->descriptor. */
2530 data = build_fold_indirect_ref_loc (input_location,
2531 gfc_conv_array_data (desc));
2532 index = gfc_build_array_ref (data, index, NULL);
2533 index = gfc_evaluate_now (index, &se->pre);
2534 index = fold_convert (gfc_array_index_type, index);
2536 /* Do any bounds checking on the final info->descriptor index. */
2537 index = gfc_trans_array_bound_check (se, info->descriptor,
2538 index, dim, &ar->where,
2539 ar->as->type != AS_ASSUMED_SIZE
2540 || dim < ar->dimen - 1);
2544 /* Scalarized dimension. */
2545 gcc_assert (info && se->loop);
2547 /* Multiply the loop variable by the stride and delta. */
2548 index = se->loop->loopvar[i];
2549 if (!integer_onep (info->stride[dim]))
2550 index = fold_build2_loc (input_location, MULT_EXPR,
2551 gfc_array_index_type, index,
2553 if (!integer_zerop (info->delta[dim]))
2554 index = fold_build2_loc (input_location, PLUS_EXPR,
2555 gfc_array_index_type, index,
2565 /* Temporary array or derived type component. */
2566 gcc_assert (se->loop);
2567 index = se->loop->loopvar[se->loop->order[i]];
2568 if (!integer_zerop (info->delta[dim]))
2569 index = fold_build2_loc (input_location, PLUS_EXPR,
2570 gfc_array_index_type, index, info->delta[dim]);
2573 /* Multiply by the stride. */
2574 if (!integer_onep (stride))
2575 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2582 /* Build a scalarized reference to an array. */
2585 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2588 tree decl = NULL_TREE;
2593 info = &se->ss->data.info;
2595 n = se->loop->order[0];
2599 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2601 /* Add the offset for this dimension to the stored offset for all other
2603 if (!integer_zerop (info->offset))
2604 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2605 index, info->offset);
2607 if (se->ss->expr && is_subref_array (se->ss->expr))
2608 decl = se->ss->expr->symtree->n.sym->backend_decl;
2610 tmp = build_fold_indirect_ref_loc (input_location,
2612 se->expr = gfc_build_array_ref (tmp, index, decl);
2616 /* Translate access of temporary array. */
2619 gfc_conv_tmp_array_ref (gfc_se * se)
2621 se->string_length = se->ss->string_length;
2622 gfc_conv_scalarized_array_ref (se, NULL);
2623 gfc_advance_se_ss_chain (se);
2626 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2629 add_to_offset (tree *cst_offset, tree *offset, tree t)
2631 if (TREE_CODE (t) == INTEGER_CST)
2632 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2635 if (!integer_zerop (*offset))
2636 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2637 gfc_array_index_type, *offset, t);
2643 /* Build an array reference. se->expr already holds the array descriptor.
2644 This should be either a variable, indirect variable reference or component
2645 reference. For arrays which do not have a descriptor, se->expr will be
2647 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2650 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2654 tree offset, cst_offset;
2662 gcc_assert (ar->codimen);
2664 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2665 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2668 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2669 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2670 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2672 /* Use the actual tree type and not the wrapped coarray. */
2673 if (!se->want_pointer)
2674 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2681 /* Handle scalarized references separately. */
2682 if (ar->type != AR_ELEMENT)
2684 gfc_conv_scalarized_array_ref (se, ar);
2685 gfc_advance_se_ss_chain (se);
2689 cst_offset = offset = gfc_index_zero_node;
2690 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2692 /* Calculate the offsets from all the dimensions. Make sure to associate
2693 the final offset so that we form a chain of loop invariant summands. */
2694 for (n = ar->dimen - 1; n >= 0; n--)
2696 /* Calculate the index for this dimension. */
2697 gfc_init_se (&indexse, se);
2698 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2699 gfc_add_block_to_block (&se->pre, &indexse.pre);
2701 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2703 /* Check array bounds. */
2707 /* Evaluate the indexse.expr only once. */
2708 indexse.expr = save_expr (indexse.expr);
2711 tmp = gfc_conv_array_lbound (se->expr, n);
2712 if (sym->attr.temporary)
2714 gfc_init_se (&tmpse, se);
2715 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2716 gfc_array_index_type);
2717 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2721 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2723 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2724 "below lower bound of %%ld", n+1, sym->name);
2725 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2726 fold_convert (long_integer_type_node,
2728 fold_convert (long_integer_type_node, tmp));
2731 /* Upper bound, but not for the last dimension of assumed-size
2733 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2735 tmp = gfc_conv_array_ubound (se->expr, n);
2736 if (sym->attr.temporary)
2738 gfc_init_se (&tmpse, se);
2739 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2740 gfc_array_index_type);
2741 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2745 cond = fold_build2_loc (input_location, GT_EXPR,
2746 boolean_type_node, indexse.expr, tmp);
2747 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2748 "above upper bound of %%ld", n+1, sym->name);
2749 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2750 fold_convert (long_integer_type_node,
2752 fold_convert (long_integer_type_node, tmp));
2757 /* Multiply the index by the stride. */
2758 stride = gfc_conv_array_stride (se->expr, n);
2759 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2760 indexse.expr, stride);
2762 /* And add it to the total. */
2763 add_to_offset (&cst_offset, &offset, tmp);
2766 if (!integer_zerop (cst_offset))
2767 offset = fold_build2_loc (input_location, PLUS_EXPR,
2768 gfc_array_index_type, offset, cst_offset);
2770 /* Access the calculated element. */
2771 tmp = gfc_conv_array_data (se->expr);
2772 tmp = build_fold_indirect_ref (tmp);
2773 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2777 /* Generate the code to be executed immediately before entering a
2778 scalarization loop. */
2781 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2782 stmtblock_t * pblock)
2791 /* This code will be executed before entering the scalarization loop
2792 for this dimension. */
2793 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2795 if ((ss->useflags & flag) == 0)
2798 if (ss->type != GFC_SS_SECTION
2799 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2800 && ss->type != GFC_SS_COMPONENT)
2803 info = &ss->data.info;
2805 if (dim >= info->dimen)
2808 if (dim == info->dimen - 1)
2810 /* For the outermost loop calculate the offset due to any
2811 elemental dimensions. It will have been initialized with the
2812 base offset of the array. */
2815 for (i = 0; i < info->ref->u.ar.dimen; i++)
2817 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2820 gfc_init_se (&se, NULL);
2822 se.expr = info->descriptor;
2823 stride = gfc_conv_array_stride (info->descriptor, i);
2824 index = gfc_conv_array_index_offset (&se, info, i, -1,
2827 gfc_add_block_to_block (pblock, &se.pre);
2829 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2830 gfc_array_index_type,
2831 info->offset, index);
2832 info->offset = gfc_evaluate_now (info->offset, pblock);
2837 /* For the time being, the innermost loop is unconditionally on
2838 the first dimension of the scalarization loop. */
2839 gcc_assert (i == 0);
2840 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2842 /* Calculate the stride of the innermost loop. Hopefully this will
2843 allow the backend optimizers to do their stuff more effectively.
2845 info->stride0 = gfc_evaluate_now (stride, pblock);
2849 /* Add the offset for the previous loop dimension. */
2854 ar = &info->ref->u.ar;
2855 i = loop->order[dim + 1];
2863 gfc_init_se (&se, NULL);
2865 se.expr = info->descriptor;
2866 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2867 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2869 gfc_add_block_to_block (pblock, &se.pre);
2870 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2871 gfc_array_index_type, info->offset,
2873 info->offset = gfc_evaluate_now (info->offset, pblock);
2876 /* Remember this offset for the second loop. */
2877 if (dim == loop->temp_dim - 1)
2878 info->saved_offset = info->offset;
2883 /* Start a scalarized expression. Creates a scope and declares loop
2887 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2893 gcc_assert (!loop->array_parameter);
2895 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2897 n = loop->order[dim];
2899 gfc_start_block (&loop->code[n]);
2901 /* Create the loop variable. */
2902 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2904 if (dim < loop->temp_dim)
2908 /* Calculate values that will be constant within this loop. */
2909 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2911 gfc_start_block (pbody);
2915 /* Generates the actual loop code for a scalarization loop. */
2918 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2919 stmtblock_t * pbody)
2930 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2931 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2932 && n == loop->dimen - 1)
2934 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2935 init = make_tree_vec (1);
2936 cond = make_tree_vec (1);
2937 incr = make_tree_vec (1);
2939 /* Cycle statement is implemented with a goto. Exit statement must not
2940 be present for this loop. */
2941 exit_label = gfc_build_label_decl (NULL_TREE);
2942 TREE_USED (exit_label) = 1;
2944 /* Label for cycle statements (if needed). */
2945 tmp = build1_v (LABEL_EXPR, exit_label);
2946 gfc_add_expr_to_block (pbody, tmp);
2948 stmt = make_node (OMP_FOR);
2950 TREE_TYPE (stmt) = void_type_node;
2951 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2953 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2954 OMP_CLAUSE_SCHEDULE);
2955 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2956 = OMP_CLAUSE_SCHEDULE_STATIC;
2957 if (ompws_flags & OMPWS_NOWAIT)
2958 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2959 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2961 /* Initialize the loopvar. */
2962 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2964 OMP_FOR_INIT (stmt) = init;
2965 /* The exit condition. */
2966 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2968 loop->loopvar[n], loop->to[n]);
2969 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2970 OMP_FOR_COND (stmt) = cond;
2971 /* Increment the loopvar. */
2972 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2973 loop->loopvar[n], gfc_index_one_node);
2974 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2975 void_type_node, loop->loopvar[n], tmp);
2976 OMP_FOR_INCR (stmt) = incr;
2978 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2979 gfc_add_expr_to_block (&loop->code[n], stmt);
2983 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2984 && (loop->temp_ss == NULL);
2986 loopbody = gfc_finish_block (pbody);
2990 tmp = loop->from[n];
2991 loop->from[n] = loop->to[n];
2995 /* Initialize the loopvar. */
2996 if (loop->loopvar[n] != loop->from[n])
2997 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2999 exit_label = gfc_build_label_decl (NULL_TREE);
3001 /* Generate the loop body. */
3002 gfc_init_block (&block);
3004 /* The exit condition. */
3005 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3006 boolean_type_node, loop->loopvar[n], loop->to[n]);
3007 tmp = build1_v (GOTO_EXPR, exit_label);
3008 TREE_USED (exit_label) = 1;
3009 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3010 gfc_add_expr_to_block (&block, tmp);
3012 /* The main body. */
3013 gfc_add_expr_to_block (&block, loopbody);
3015 /* Increment the loopvar. */
3016 tmp = fold_build2_loc (input_location,
3017 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3018 gfc_array_index_type, loop->loopvar[n],
3019 gfc_index_one_node);
3021 gfc_add_modify (&block, loop->loopvar[n], tmp);
3023 /* Build the loop. */
3024 tmp = gfc_finish_block (&block);
3025 tmp = build1_v (LOOP_EXPR, tmp);
3026 gfc_add_expr_to_block (&loop->code[n], tmp);
3028 /* Add the exit label. */
3029 tmp = build1_v (LABEL_EXPR, exit_label);
3030 gfc_add_expr_to_block (&loop->code[n], tmp);
3036 /* Finishes and generates the loops for a scalarized expression. */
3039 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3044 stmtblock_t *pblock;
3048 /* Generate the loops. */
3049 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
3051 n = loop->order[dim];
3052 gfc_trans_scalarized_loop_end (loop, n, pblock);
3053 loop->loopvar[n] = NULL_TREE;
3054 pblock = &loop->code[n];
3057 tmp = gfc_finish_block (pblock);
3058 gfc_add_expr_to_block (&loop->pre, tmp);
3060 /* Clear all the used flags. */
3061 for (ss = loop->ss; ss; ss = ss->loop_chain)
3066 /* Finish the main body of a scalarized expression, and start the secondary
3070 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3074 stmtblock_t *pblock;
3078 /* We finish as many loops as are used by the temporary. */
3079 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3081 n = loop->order[dim];
3082 gfc_trans_scalarized_loop_end (loop, n, pblock);
3083 loop->loopvar[n] = NULL_TREE;
3084 pblock = &loop->code[n];
3087 /* We don't want to finish the outermost loop entirely. */
3088 n = loop->order[loop->temp_dim - 1];
3089 gfc_trans_scalarized_loop_end (loop, n, pblock);
3091 /* Restore the initial offsets. */
3092 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3094 if ((ss->useflags & 2) == 0)
3097 if (ss->type != GFC_SS_SECTION
3098 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3099 && ss->type != GFC_SS_COMPONENT)
3102 ss->data.info.offset = ss->data.info.saved_offset;
3105 /* Restart all the inner loops we just finished. */
3106 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3108 n = loop->order[dim];
3110 gfc_start_block (&loop->code[n]);
3112 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3114 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3117 /* Start a block for the secondary copying code. */
3118 gfc_start_block (body);
3122 /* Calculate the lower bound of an array section. */
3125 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3126 bool coarray, bool coarray_last)
3130 gfc_expr *stride = NULL;
3135 gcc_assert (ss->type == GFC_SS_SECTION);
3137 info = &ss->data.info;
3139 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3141 /* We use a zero-based index to access the vector. */
3142 info->start[dim] = gfc_index_zero_node;
3143 info->end[dim] = NULL;
3145 info->stride[dim] = gfc_index_one_node;
3149 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3150 desc = info->descriptor;
3151 start = info->ref->u.ar.start[dim];
3152 end = info->ref->u.ar.end[dim];
3154 stride = info->ref->u.ar.stride[dim];
3156 /* Calculate the start of the range. For vector subscripts this will
3157 be the range of the vector. */
3160 /* Specified section start. */
3161 gfc_init_se (&se, NULL);
3162 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3163 gfc_add_block_to_block (&loop->pre, &se.pre);
3164 info->start[dim] = se.expr;
3168 /* No lower bound specified so use the bound of the array. */
3169 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3171 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3173 /* Similarly calculate the end. Although this is not used in the
3174 scalarizer, it is needed when checking bounds and where the end
3175 is an expression with side-effects. */
3180 /* Specified section start. */
3181 gfc_init_se (&se, NULL);
3182 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3183 gfc_add_block_to_block (&loop->pre, &se.pre);
3184 info->end[dim] = se.expr;
3188 /* No upper bound specified so use the bound of the array. */
3189 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3191 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3194 /* Calculate the stride. */
3195 if (!coarray && stride == NULL)
3196 info->stride[dim] = gfc_index_one_node;
3199 gfc_init_se (&se, NULL);
3200 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3201 gfc_add_block_to_block (&loop->pre, &se.pre);
3202 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3207 /* Calculates the range start and stride for a SS chain. Also gets the
3208 descriptor and data pointer. The range of vector subscripts is the size
3209 of the vector. Array bounds are also checked. */
3212 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3220 /* Determine the rank of the loop. */
3222 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3226 case GFC_SS_SECTION:
3227 case GFC_SS_CONSTRUCTOR:
3228 case GFC_SS_FUNCTION:
3229 case GFC_SS_COMPONENT:
3230 loop->dimen = ss->data.info.dimen;
3231 loop->codimen = ss->data.info.codimen;
3234 /* As usual, lbound and ubound are exceptions!. */
3235 case GFC_SS_INTRINSIC:
3236 switch (ss->expr->value.function.isym->id)
3238 case GFC_ISYM_LBOUND:
3239 case GFC_ISYM_UBOUND:
3240 loop->dimen = ss->data.info.dimen;
3244 case GFC_ISYM_LCOBOUND:
3245 case GFC_ISYM_UCOBOUND:
3246 case GFC_ISYM_THIS_IMAGE:
3247 loop->dimen = ss->data.info.dimen;
3248 loop->codimen = ss->data.info.codimen;
3260 /* We should have determined the rank of the expression by now. If
3261 not, that's bad news. */
3262 gcc_assert (loop->dimen + loop->codimen != 0);
3264 /* Loop over all the SS in the chain. */
3265 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3267 if (ss->expr && ss->expr->shape && !ss->shape)
3268 ss->shape = ss->expr->shape;
3272 case GFC_SS_SECTION:
3273 /* Get the descriptor for the array. */
3274 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3276 for (n = 0; n < ss->data.info.dimen; n++)
3277 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3279 for (n = ss->data.info.dimen;
3280 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3281 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3282 n == ss->data.info.dimen
3283 + ss->data.info.codimen -1);
3287 case GFC_SS_INTRINSIC:
3288 switch (ss->expr->value.function.isym->id)
3290 /* Fall through to supply start and stride. */
3291 case GFC_ISYM_LBOUND:
3292 case GFC_ISYM_UBOUND:
3293 case GFC_ISYM_LCOBOUND:
3294 case GFC_ISYM_UCOBOUND:
3295 case GFC_ISYM_THIS_IMAGE:
3302 case GFC_SS_CONSTRUCTOR:
3303 case GFC_SS_FUNCTION:
3304 for (n = 0; n < ss->data.info.dimen; n++)
3306 ss->data.info.start[n] = gfc_index_zero_node;
3307 ss->data.info.end[n] = gfc_index_zero_node;
3308 ss->data.info.stride[n] = gfc_index_one_node;
3317 /* The rest is just runtime bound checking. */
3318 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3321 tree lbound, ubound;
3323 tree size[GFC_MAX_DIMENSIONS];
3324 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3329 gfc_start_block (&block);
3331 for (n = 0; n < loop->dimen; n++)
3332 size[n] = NULL_TREE;
3334 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3338 if (ss->type != GFC_SS_SECTION)
3341 /* Catch allocatable lhs in f2003. */
3342 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3345 gfc_start_block (&inner);
3347 /* TODO: range checking for mapped dimensions. */
3348 info = &ss->data.info;
3350 /* This code only checks ranges. Elemental and vector
3351 dimensions are checked later. */
3352 for (n = 0; n < loop->dimen; n++)
3357 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3360 if (dim == info->ref->u.ar.dimen - 1
3361 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3362 check_upper = false;
3366 /* Zero stride is not allowed. */
3367 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3368 info->stride[dim], gfc_index_zero_node);
3369 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3370 "of array '%s'", dim + 1, ss->expr->symtree->name);
3371 gfc_trans_runtime_check (true, false, tmp, &inner,
3372 &ss->expr->where, msg);
3375 desc = ss->data.info.descriptor;
3377 /* This is the run-time equivalent of resolve.c's
3378 check_dimension(). The logical is more readable there
3379 than it is here, with all the trees. */
3380 lbound = gfc_conv_array_lbound (desc, dim);
3381 end = info->end[dim];
3383 ubound = gfc_conv_array_ubound (desc, dim);
3387 /* non_zerosized is true when the selected range is not
3389 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3390 boolean_type_node, info->stride[dim],
3391 gfc_index_zero_node);
3392 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3393 info->start[dim], end);
3394 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3395 boolean_type_node, stride_pos, tmp);
3397 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3399 info->stride[dim], gfc_index_zero_node);
3400 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3401 info->start[dim], end);
3402 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3405 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3407 stride_pos, stride_neg);
3409 /* Check the start of the range against the lower and upper
3410 bounds of the array, if the range is not empty.
3411 If upper bound is present, include both bounds in the
3415 tmp = fold_build2_loc (input_location, LT_EXPR,
3417 info->start[dim], lbound);
3418 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3420 non_zerosized, tmp);
3421 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3423 info->start[dim], ubound);
3424 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3426 non_zerosized, tmp2);
3427 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3428 "outside of expected range (%%ld:%%ld)",
3429 dim + 1, ss->expr->symtree->name);
3430 gfc_trans_runtime_check (true, false, tmp, &inner,
3431 &ss->expr->where, msg,
3432 fold_convert (long_integer_type_node, info->start[dim]),
3433 fold_convert (long_integer_type_node, lbound),
3434 fold_convert (long_integer_type_node, ubound));
3435 gfc_trans_runtime_check (true, false, tmp2, &inner,
3436 &ss->expr->where, msg,
3437 fold_convert (long_integer_type_node, info->start[dim]),
3438 fold_convert (long_integer_type_node, lbound),
3439 fold_convert (long_integer_type_node, ubound));
3444 tmp = fold_build2_loc (input_location, LT_EXPR,
3446 info->start[dim], lbound);
3447 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3448 boolean_type_node, non_zerosized, tmp);
3449 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3450 "below lower bound of %%ld",
3451 dim + 1, ss->expr->symtree->name);
3452 gfc_trans_runtime_check (true, false, tmp, &inner,
3453 &ss->expr->where, msg,
3454 fold_convert (long_integer_type_node, info->start[dim]),
3455 fold_convert (long_integer_type_node, lbound));
3459 /* Compute the last element of the range, which is not
3460 necessarily "end" (think 0:5:3, which doesn't contain 5)
3461 and check it against both lower and upper bounds. */
3463 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3464 gfc_array_index_type, end,
3466 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3467 gfc_array_index_type, tmp,
3469 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3470 gfc_array_index_type, end, tmp);
3471 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3472 boolean_type_node, tmp, lbound);
3473 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3474 boolean_type_node, non_zerosized, tmp2);
3477 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3478 boolean_type_node, tmp, ubound);
3479 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3480 boolean_type_node, non_zerosized, tmp3);
3481 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3482 "outside of expected range (%%ld:%%ld)",
3483 dim + 1, ss->expr->symtree->name);
3484 gfc_trans_runtime_check (true, false, tmp2, &inner,
3485 &ss->expr->where, msg,
3486 fold_convert (long_integer_type_node, tmp),
3487 fold_convert (long_integer_type_node, ubound),
3488 fold_convert (long_integer_type_node, lbound));
3489 gfc_trans_runtime_check (true, false, tmp3, &inner,
3490 &ss->expr->where, msg,
3491 fold_convert (long_integer_type_node, tmp),
3492 fold_convert (long_integer_type_node, ubound),
3493 fold_convert (long_integer_type_node, lbound));
3498 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3499 "below lower bound of %%ld",
3500 dim + 1, ss->expr->symtree->name);
3501 gfc_trans_runtime_check (true, false, tmp2, &inner,
3502 &ss->expr->where, msg,
3503 fold_convert (long_integer_type_node, tmp),
3504 fold_convert (long_integer_type_node, lbound));
3508 /* Check the section sizes match. */
3509 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3510 gfc_array_index_type, end,
3512 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3513 gfc_array_index_type, tmp,
3515 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3516 gfc_array_index_type,
3517 gfc_index_one_node, tmp);
3518 tmp = fold_build2_loc (input_location, MAX_EXPR,
3519 gfc_array_index_type, tmp,
3520 build_int_cst (gfc_array_index_type, 0));
3521 /* We remember the size of the first section, and check all the
3522 others against this. */
3525 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3526 boolean_type_node, tmp, size[n]);
3527 asprintf (&msg, "Array bound mismatch for dimension %d "
3528 "of array '%s' (%%ld/%%ld)",
3529 dim + 1, ss->expr->symtree->name);
3531 gfc_trans_runtime_check (true, false, tmp3, &inner,
3532 &ss->expr->where, msg,
3533 fold_convert (long_integer_type_node, tmp),
3534 fold_convert (long_integer_type_node, size[n]));
3539 size[n] = gfc_evaluate_now (tmp, &inner);
3542 tmp = gfc_finish_block (&inner);
3544 /* For optional arguments, only check bounds if the argument is
3546 if (ss->expr->symtree->n.sym->attr.optional
3547 || ss->expr->symtree->n.sym->attr.not_always_present)
3548 tmp = build3_v (COND_EXPR,
3549 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3550 tmp, build_empty_stmt (input_location));
3552 gfc_add_expr_to_block (&block, tmp);
3556 tmp = gfc_finish_block (&block);
3557 gfc_add_expr_to_block (&loop->pre, tmp);
3561 /* Return true if both symbols could refer to the same data object. Does
3562 not take account of aliasing due to equivalence statements. */
3565 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3566 bool lsym_target, bool rsym_pointer, bool rsym_target)
3568 /* Aliasing isn't possible if the symbols have different base types. */
3569 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3572 /* Pointers can point to other pointers and target objects. */
3574 if ((lsym_pointer && (rsym_pointer || rsym_target))
3575 || (rsym_pointer && (lsym_pointer || lsym_target)))
3578 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3579 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3581 if (lsym_target && rsym_target
3582 && ((lsym->attr.dummy && !lsym->attr.contiguous
3583 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3584 || (rsym->attr.dummy && !rsym->attr.contiguous
3585 && (!rsym->attr.dimension
3586 || rsym->as->type == AS_ASSUMED_SHAPE))))
3593 /* Return true if the two SS could be aliased, i.e. both point to the same data
3595 /* TODO: resolve aliases based on frontend expressions. */
3598 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3604 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3606 lsym = lss->expr->symtree->n.sym;
3607 rsym = rss->expr->symtree->n.sym;
3609 lsym_pointer = lsym->attr.pointer;
3610 lsym_target = lsym->attr.target;
3611 rsym_pointer = rsym->attr.pointer;
3612 rsym_target = rsym->attr.target;
3614 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3615 rsym_pointer, rsym_target))
3618 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3619 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3622 /* For derived types we must check all the component types. We can ignore
3623 array references as these will have the same base type as the previous
3625 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3627 if (lref->type != REF_COMPONENT)
3630 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3631 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3633 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3634 rsym_pointer, rsym_target))
3637 if ((lsym_pointer && (rsym_pointer || rsym_target))
3638 || (rsym_pointer && (lsym_pointer || lsym_target)))
3640 if (gfc_compare_types (&lref->u.c.component->ts,
3645 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3648 if (rref->type != REF_COMPONENT)
3651 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3652 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3654 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3655 lsym_pointer, lsym_target,
3656 rsym_pointer, rsym_target))
3659 if ((lsym_pointer && (rsym_pointer || rsym_target))
3660 || (rsym_pointer && (lsym_pointer || lsym_target)))
3662 if (gfc_compare_types (&lref->u.c.component->ts,
3663 &rref->u.c.sym->ts))
3665 if (gfc_compare_types (&lref->u.c.sym->ts,
3666 &rref->u.c.component->ts))
3668 if (gfc_compare_types (&lref->u.c.component->ts,
3669 &rref->u.c.component->ts))
3675 lsym_pointer = lsym->attr.pointer;
3676 lsym_target = lsym->attr.target;
3677 lsym_pointer = lsym->attr.pointer;
3678 lsym_target = lsym->attr.target;
3680 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3682 if (rref->type != REF_COMPONENT)
3685 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3686 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3688 if (symbols_could_alias (rref->u.c.sym, lsym,
3689 lsym_pointer, lsym_target,
3690 rsym_pointer, rsym_target))
3693 if ((lsym_pointer && (rsym_pointer || rsym_target))
3694 || (rsym_pointer && (lsym_pointer || lsym_target)))
3696 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3705 /* Resolve array data dependencies. Creates a temporary if required. */
3706 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3710 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3719 loop->temp_ss = NULL;
3721 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3723 if (ss->type != GFC_SS_SECTION)
3726 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3728 if (gfc_could_be_alias (dest, ss)
3729 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3737 lref = dest->expr->ref;
3738 rref = ss->expr->ref;
3740 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3745 for (i = 0; i < dest->data.info.dimen; i++)
3746 for (j = 0; j < ss->data.info.dimen; j++)
3748 && dest->data.info.dim[i] == ss->data.info.dim[j])
3750 /* If we don't access array elements in the same order,
3751 there is a dependency. */
3756 /* TODO : loop shifting. */
3759 /* Mark the dimensions for LOOP SHIFTING */
3760 for (n = 0; n < loop->dimen; n++)
3762 int dim = dest->data.info.dim[n];
3764 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3766 else if (! gfc_is_same_range (&lref->u.ar,
3767 &rref->u.ar, dim, 0))
3771 /* Put all the dimensions with dependencies in the
3774 for (n = 0; n < loop->dimen; n++)
3776 gcc_assert (loop->order[n] == n);
3778 loop->order[dim++] = n;
3780 for (n = 0; n < loop->dimen; n++)
3783 loop->order[dim++] = n;
3786 gcc_assert (dim == loop->dimen);
3797 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3798 if (GFC_ARRAY_TYPE_P (base_type)
3799 || GFC_DESCRIPTOR_TYPE_P (base_type))
3800 base_type = gfc_get_element_type (base_type);
3801 loop->temp_ss = gfc_get_ss ();
3802 loop->temp_ss->type = GFC_SS_TEMP;
3803 loop->temp_ss->data.temp.type = base_type;
3804 loop->temp_ss->string_length = dest->string_length;
3805 loop->temp_ss->data.temp.dimen = loop->dimen;
3806 loop->temp_ss->data.temp.codimen = loop->codimen;
3807 loop->temp_ss->next = gfc_ss_terminator;
3808 gfc_add_ss_to_loop (loop, loop->temp_ss);
3811 loop->temp_ss = NULL;
3815 /* Initialize the scalarization loop. Creates the loop variables. Determines
3816 the range of the loop variables. Creates a temporary if required.
3817 Calculates how to transform from loop variables to array indices for each
3818 expression. Also generates code for scalar expressions which have been
3819 moved outside the loop. */
3822 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3824 int n, dim, spec_dim;
3826 gfc_ss_info *specinfo;
3829 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3830 bool dynamic[GFC_MAX_DIMENSIONS];
3835 for (n = 0; n < loop->dimen + loop->codimen; n++)
3839 /* We use one SS term, and use that to determine the bounds of the
3840 loop for this dimension. We try to pick the simplest term. */
3841 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3843 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3846 info = &ss->data.info;
3849 if (loopspec[n] != NULL)
3851 specinfo = &loopspec[n]->data.info;
3852 spec_dim = specinfo->dim[n];
3856 /* Silence unitialized warnings. */
3863 gcc_assert (ss->shape[dim]);
3864 /* The frontend has worked out the size for us. */
3866 || !loopspec[n]->shape
3867 || !integer_zerop (specinfo->start[spec_dim]))
3868 /* Prefer zero-based descriptors if possible. */
3873 if (ss->type == GFC_SS_CONSTRUCTOR)
3875 gfc_constructor_base base;
3876 /* An unknown size constructor will always be rank one.
3877 Higher rank constructors will either have known shape,
3878 or still be wrapped in a call to reshape. */
3879 gcc_assert (loop->dimen == 1);
3881 /* Always prefer to use the constructor bounds if the size
3882 can be determined at compile time. Prefer not to otherwise,
3883 since the general case involves realloc, and it's better to
3884 avoid that overhead if possible. */
3885 base = ss->expr->value.constructor;
3886 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3887 if (!dynamic[n] || !loopspec[n])
3892 /* TODO: Pick the best bound if we have a choice between a
3893 function and something else. */
3894 if (ss->type == GFC_SS_FUNCTION)
3900 /* Avoid using an allocatable lhs in an assignment, since
3901 there might be a reallocation coming. */
3902 if (loopspec[n] && ss->is_alloc_lhs)
3905 if (ss->type != GFC_SS_SECTION)
3910 /* Criteria for choosing a loop specifier (most important first):
3911 doesn't need realloc
3917 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3918 || n >= loop->dimen)
3920 else if (integer_onep (info->stride[dim])
3921 && !integer_onep (specinfo->stride[spec_dim]))
3923 else if (INTEGER_CST_P (info->stride[dim])
3924 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3926 else if (INTEGER_CST_P (info->start[dim])
3927 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3929 /* We don't work out the upper bound.
3930 else if (INTEGER_CST_P (info->finish[n])
3931 && ! INTEGER_CST_P (specinfo->finish[n]))
3932 loopspec[n] = ss; */
3935 /* We should have found the scalarization loop specifier. If not,
3937 gcc_assert (loopspec[n]);
3939 info = &loopspec[n]->data.info;
3942 /* Set the extents of this range. */
3943 cshape = loopspec[n]->shape;
3944 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3945 && INTEGER_CST_P (info->stride[dim]))
3947 loop->from[n] = info->start[dim];
3948 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3949 mpz_sub_ui (i, i, 1);
3950 /* To = from + (size - 1) * stride. */
3951 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3952 if (!integer_onep (info->stride[dim]))
3953 tmp = fold_build2_loc (input_location, MULT_EXPR,
3954 gfc_array_index_type, tmp,
3956 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3957 gfc_array_index_type,
3958 loop->from[n], tmp);
3962 loop->from[n] = info->start[dim];
3963 switch (loopspec[n]->type)
3965 case GFC_SS_CONSTRUCTOR:
3966 /* The upper bound is calculated when we expand the
3968 gcc_assert (loop->to[n] == NULL_TREE);
3971 case GFC_SS_SECTION:
3972 /* Use the end expression if it exists and is not constant,
3973 so that it is only evaluated once. */
3974 loop->to[n] = info->end[dim];
3977 case GFC_SS_FUNCTION:
3978 /* The loop bound will be set when we generate the call. */
3979 gcc_assert (loop->to[n] == NULL_TREE);
3987 /* Transform everything so we have a simple incrementing variable. */
3988 if (n < loop->dimen && integer_onep (info->stride[dim]))
3989 info->delta[dim] = gfc_index_zero_node;
3990 else if (n < loop->dimen)
3992 /* Set the delta for this section. */
3993 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3994 /* Number of iterations is (end - start + step) / step.
3995 with start = 0, this simplifies to
3997 for (i = 0; i<=last; i++){...}; */
3998 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3999 gfc_array_index_type, loop->to[n],
4001 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4002 gfc_array_index_type, tmp, info->stride[dim]);
4003 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4004 tmp, build_int_cst (gfc_array_index_type, -1));
4005 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4006 /* Make the loop variable start at 0. */
4007 loop->from[n] = gfc_index_zero_node;
4011 /* Add all the scalar code that can be taken out of the loops.
4012 This may include calculating the loop bounds, so do it before
4013 allocating the temporary. */
4014 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4016 /* If we want a temporary then create it. */
4017 if (loop->temp_ss != NULL)
4019 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
4021 /* Make absolutely sure that this is a complete type. */
4022 if (loop->temp_ss->string_length)
4023 loop->temp_ss->data.temp.type
4024 = gfc_get_character_type_len_for_eltype
4025 (TREE_TYPE (loop->temp_ss->data.temp.type),
4026 loop->temp_ss->string_length);
4028 tmp = loop->temp_ss->data.temp.type;
4029 n = loop->temp_ss->data.temp.dimen;
4030 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
4031 loop->temp_ss->type = GFC_SS_SECTION;
4032 loop->temp_ss->data.info.dimen = n;
4034 gcc_assert (loop->temp_ss->data.info.dimen != 0);
4035 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
4036 loop->temp_ss->data.info.dim[n] = n;
4038 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4039 &loop->temp_ss->data.info, tmp, NULL_TREE,
4040 false, true, false, where);
4043 for (n = 0; n < loop->temp_dim; n++)
4044 loopspec[loop->order[n]] = NULL;
4048 /* For array parameters we don't have loop variables, so don't calculate the
4050 if (loop->array_parameter)
4053 /* Calculate the translation from loop variables to array indices. */
4054 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4056 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4057 && ss->type != GFC_SS_CONSTRUCTOR)
4061 info = &ss->data.info;
4063 for (n = 0; n < info->dimen; n++)
4065 /* If we are specifying the range the delta is already set. */
4066 if (loopspec[n] != ss)
4068 dim = ss->data.info.dim[n];
4070 /* Calculate the offset relative to the loop variable.
4071 First multiply by the stride. */
4072 tmp = loop->from[n];
4073 if (!integer_onep (info->stride[dim]))
4074 tmp = fold_build2_loc (input_location, MULT_EXPR,
4075 gfc_array_index_type,
4076 tmp, info->stride[dim]);
4078 /* Then subtract this from our starting value. */
4079 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4080 gfc_array_index_type,
4081 info->start[dim], tmp);
4083 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4090 /* Calculate the size of a given array dimension from the bounds. This
4091 is simply (ubound - lbound + 1) if this expression is positive
4092 or 0 if it is negative (pick either one if it is zero). Optionally
4093 (if or_expr is present) OR the (expression != 0) condition to it. */
4096 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4101 /* Calculate (ubound - lbound + 1). */
4102 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4104 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4105 gfc_index_one_node);
4107 /* Check whether the size for this dimension is negative. */
4108 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4109 gfc_index_zero_node);
4110 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4111 gfc_index_zero_node, res);
4113 /* Build OR expression. */
4115 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4116 boolean_type_node, *or_expr, cond);
4122 /* For an array descriptor, get the total number of elements. This is just
4123 the product of the extents along from_dim to to_dim. */
4126 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4131 res = gfc_index_one_node;
4133 for (dim = from_dim; dim < to_dim; ++dim)
4139 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4140 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4142 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4143 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4151 /* Full size of an array. */
4154 gfc_conv_descriptor_size (tree desc, int rank)
4156 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4160 /* Size of a coarray for all dimensions but the last. */
4163 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4165 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4169 /* Fills in an array descriptor, and returns the size of the array.
4170 The size will be a simple_val, ie a variable or a constant. Also
4171 calculates the offset of the base. The pointer argument overflow,
4172 which should be of integer type, will increase in value if overflow
4173 occurs during the size calculation. Returns the size of the array.
4177 for (n = 0; n < rank; n++)
4179 a.lbound[n] = specified_lower_bound;
4180 offset = offset + a.lbond[n] * stride;
4182 a.ubound[n] = specified_upper_bound;
4183 a.stride[n] = stride;
4184 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4185 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4186 stride = stride * size;
4188 for (n = rank; n < rank+corank; n++)
4189 (Set lcobound/ucobound as above.)
4190 element_size = sizeof (array element);
4193 stride = (size_t) stride;
4194 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4195 stride = stride * element_size;
4201 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4202 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4203 stmtblock_t * descriptor_block, tree * overflow)
4216 stmtblock_t thenblock;
4217 stmtblock_t elseblock;
4222 type = TREE_TYPE (descriptor);
4224 stride = gfc_index_one_node;
4225 offset = gfc_index_zero_node;
4227 /* Set the dtype. */
4228 tmp = gfc_conv_descriptor_dtype (descriptor);
4229 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4231 or_expr = boolean_false_node;
4233 for (n = 0; n < rank; n++)
4238 /* We have 3 possibilities for determining the size of the array:
4239 lower == NULL => lbound = 1, ubound = upper[n]
4240 upper[n] = NULL => lbound = 1, ubound = lower[n]
4241 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4244 /* Set lower bound. */
4245 gfc_init_se (&se, NULL);
4247 se.expr = gfc_index_one_node;
4250 gcc_assert (lower[n]);
4253 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4254 gfc_add_block_to_block (pblock, &se.pre);
4258 se.expr = gfc_index_one_node;
4262 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4263 gfc_rank_cst[n], se.expr);
4264 conv_lbound = se.expr;
4266 /* Work out the offset for this component. */
4267 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4269 offset = fold_build2_loc (input_location, MINUS_EXPR,
4270 gfc_array_index_type, offset, tmp);
4272 /* Set upper bound. */
4273 gfc_init_se (&se, NULL);
4274 gcc_assert (ubound);
4275 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4276 gfc_add_block_to_block (pblock, &se.pre);
4278 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4279 gfc_rank_cst[n], se.expr);
4280 conv_ubound = se.expr;
4282 /* Store the stride. */
4283 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4284 gfc_rank_cst[n], stride);
4286 /* Calculate size and check whether extent is negative. */
4287 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4288 size = gfc_evaluate_now (size, pblock);
4290 /* Check whether multiplying the stride by the number of
4291 elements in this dimension would overflow. We must also check
4292 whether the current dimension has zero size in order to avoid
4295 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4296 gfc_array_index_type,
4297 fold_convert (gfc_array_index_type,
4298 TYPE_MAX_VALUE (gfc_array_index_type)),
4300 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4301 boolean_type_node, tmp, stride));
4302 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4303 integer_one_node, integer_zero_node);
4304 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4305 boolean_type_node, size,
4306 gfc_index_zero_node));
4307 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4308 integer_zero_node, tmp);
4309 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4311 *overflow = gfc_evaluate_now (tmp, pblock);
4313 /* Multiply the stride by the number of elements in this dimension. */
4314 stride = fold_build2_loc (input_location, MULT_EXPR,
4315 gfc_array_index_type, stride, size);
4316 stride = gfc_evaluate_now (stride, pblock);
4319 for (n = rank; n < rank + corank; n++)
4323 /* Set lower bound. */
4324 gfc_init_se (&se, NULL);
4325 if (lower == NULL || lower[n] == NULL)
4327 gcc_assert (n == rank + corank - 1);
4328 se.expr = gfc_index_one_node;
4332 if (ubound || n == rank + corank - 1)
4334 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4335 gfc_add_block_to_block (pblock, &se.pre);
4339 se.expr = gfc_index_one_node;
4343 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4344 gfc_rank_cst[n], se.expr);
4346 if (n < rank + corank - 1)
4348 gfc_init_se (&se, NULL);
4349 gcc_assert (ubound);
4350 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4351 gfc_add_block_to_block (pblock, &se.pre);
4352 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4353 gfc_rank_cst[n], se.expr);
4357 /* The stride is the number of elements in the array, so multiply by the
4358 size of an element to get the total size. */
4359 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4360 /* Convert to size_t. */
4361 element_size = fold_convert (size_type_node, tmp);
4364 return element_size;
4366 stride = fold_convert (size_type_node, stride);
4368 /* First check for overflow. Since an array of type character can
4369 have zero element_size, we must check for that before
4371 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4373 TYPE_MAX_VALUE (size_type_node), element_size);
4374 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4375 boolean_type_node, tmp, stride));
4376 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4377 integer_one_node, integer_zero_node);
4378 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4379 boolean_type_node, element_size,
4380 build_int_cst (size_type_node, 0)));
4381 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4382 integer_zero_node, tmp);
4383 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4385 *overflow = gfc_evaluate_now (tmp, pblock);
4387 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4388 stride, element_size);
4390 if (poffset != NULL)
4392 offset = gfc_evaluate_now (offset, pblock);
4396 if (integer_zerop (or_expr))
4398 if (integer_onep (or_expr))
4399 return build_int_cst (size_type_node, 0);
4401 var = gfc_create_var (TREE_TYPE (size), "size");
4402 gfc_start_block (&thenblock);
4403 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4404 thencase = gfc_finish_block (&thenblock);
4406 gfc_start_block (&elseblock);
4407 gfc_add_modify (&elseblock, var, size);
4408 elsecase = gfc_finish_block (&elseblock);
4410 tmp = gfc_evaluate_now (or_expr, pblock);
4411 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4412 gfc_add_expr_to_block (pblock, tmp);
4418 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4419 the work for an ALLOCATE statement. */
4423 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4428 tree offset = NULL_TREE;
4429 tree token = NULL_TREE;
4432 tree error = NULL_TREE;
4433 tree overflow; /* Boolean storing whether size calculation overflows. */
4434 tree var_overflow = NULL_TREE;
4436 tree set_descriptor;
4437 stmtblock_t set_descriptor_block;
4438 stmtblock_t elseblock;
4441 gfc_ref *ref, *prev_ref = NULL;
4442 bool allocatable, coarray, dimension;
4446 /* Find the last reference in the chain. */
4447 while (ref && ref->next != NULL)
4449 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4450 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4455 if (ref == NULL || ref->type != REF_ARRAY)
4460 allocatable = expr->symtree->n.sym->attr.allocatable;
4461 coarray = expr->symtree->n.sym->attr.codimension;
4462 dimension = expr->symtree->n.sym->attr.dimension;
4466 allocatable = prev_ref->u.c.component->attr.allocatable;
4467 coarray = prev_ref->u.c.component->attr.codimension;
4468 dimension = prev_ref->u.c.component->attr.dimension;
4472 gcc_assert (coarray);
4474 /* Figure out the size of the array. */
4475 switch (ref->u.ar.type)
4481 upper = ref->u.ar.start;
4487 lower = ref->u.ar.start;
4488 upper = ref->u.ar.end;
4492 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4494 lower = ref->u.ar.as->lower;
4495 upper = ref->u.ar.as->upper;
4503 overflow = integer_zero_node;
4505 gfc_init_block (&set_descriptor_block);
4506 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4507 ref->u.ar.as->corank, &offset, lower, upper,
4508 &se->pre, &set_descriptor_block, &overflow);
4513 var_overflow = gfc_create_var (integer_type_node, "overflow");
4514 gfc_add_modify (&se->pre, var_overflow, overflow);
4516 /* Generate the block of code handling overflow. */
4517 msg = gfc_build_addr_expr (pchar_type_node,
4518 gfc_build_localized_cstring_const
4519 ("Integer overflow when calculating the amount of "
4520 "memory to allocate"));
4521 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4525 if (status != NULL_TREE)
4527 tree status_type = TREE_TYPE (status);
4528 stmtblock_t set_status_block;
4530 gfc_start_block (&set_status_block);
4531 gfc_add_modify (&set_status_block, status,
4532 build_int_cst (status_type, LIBERROR_ALLOCATION));
4533 error = gfc_finish_block (&set_status_block);
4536 gfc_start_block (&elseblock);
4538 /* Allocate memory to store the data. */
4539 pointer = gfc_conv_descriptor_data_get (se->expr);
4540 STRIP_NOPS (pointer);
4542 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4543 token = gfc_build_addr_expr (NULL_TREE,
4544 gfc_conv_descriptor_token (se->expr));
4546 /* The allocatable variant takes the old pointer as first argument. */
4548 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4549 status, errmsg, errlen, expr);
4551 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4555 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4556 boolean_type_node, var_overflow, integer_zero_node));
4557 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4558 error, gfc_finish_block (&elseblock));
4561 tmp = gfc_finish_block (&elseblock);
4563 gfc_add_expr_to_block (&se->pre, tmp);
4565 /* Update the array descriptors. */
4567 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4569 set_descriptor = gfc_finish_block (&set_descriptor_block);
4570 if (status != NULL_TREE)
4572 cond = fold_build2_loc (input_location, EQ_EXPR,
4573 boolean_type_node, status,
4574 build_int_cst (TREE_TYPE (status), 0));
4575 gfc_add_expr_to_block (&se->pre,
4576 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4577 gfc_likely (cond), set_descriptor,
4578 build_empty_stmt (input_location)));
4581 gfc_add_expr_to_block (&se->pre, set_descriptor);
4583 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4584 && expr->ts.u.derived->attr.alloc_comp)
4586 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4587 ref->u.ar.as->rank);
4588 gfc_add_expr_to_block (&se->pre, tmp);
4595 /* Deallocate an array variable. Also used when an allocated variable goes
4600 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4606 gfc_start_block (&block);
4607 /* Get a pointer to the data. */
4608 var = gfc_conv_descriptor_data_get (descriptor);
4611 /* Parameter is the address of the data component. */
4612 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4613 gfc_add_expr_to_block (&block, tmp);
4615 /* Zero the data pointer. */
4616 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4617 var, build_int_cst (TREE_TYPE (var), 0));
4618 gfc_add_expr_to_block (&block, tmp);
4620 return gfc_finish_block (&block);
4624 /* Create an array constructor from an initialization expression.
4625 We assume the frontend already did any expansions and conversions. */
4628 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4634 unsigned HOST_WIDE_INT lo;
4636 VEC(constructor_elt,gc) *v = NULL;
4638 switch (expr->expr_type)
4641 case EXPR_STRUCTURE:
4642 /* A single scalar or derived type value. Create an array with all
4643 elements equal to that value. */
4644 gfc_init_se (&se, NULL);
4646 if (expr->expr_type == EXPR_CONSTANT)
4647 gfc_conv_constant (&se, expr);
4649 gfc_conv_structure (&se, expr, 1);
4651 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4652 gcc_assert (tmp && INTEGER_CST_P (tmp));
4653 hi = TREE_INT_CST_HIGH (tmp);
4654 lo = TREE_INT_CST_LOW (tmp);
4658 /* This will probably eat buckets of memory for large arrays. */
4659 while (hi != 0 || lo != 0)
4661 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4669 /* Create a vector of all the elements. */
4670 for (c = gfc_constructor_first (expr->value.constructor);
4671 c; c = gfc_constructor_next (c))
4675 /* Problems occur when we get something like
4676 integer :: a(lots) = (/(i, i=1, lots)/) */
4677 gfc_fatal_error ("The number of elements in the array constructor "
4678 "at %L requires an increase of the allowed %d "
4679 "upper limit. See -fmax-array-constructor "
4680 "option", &expr->where,
4681 gfc_option.flag_max_array_constructor);
4684 if (mpz_cmp_si (c->offset, 0) != 0)
4685 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4689 if (mpz_cmp_si (c->repeat, 1) > 0)
4695 mpz_add (maxval, c->offset, c->repeat);
4696 mpz_sub_ui (maxval, maxval, 1);
4697 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4698 if (mpz_cmp_si (c->offset, 0) != 0)
4700 mpz_add_ui (maxval, c->offset, 1);
4701 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4704 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4706 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4712 gfc_init_se (&se, NULL);
4713 switch (c->expr->expr_type)
4716 gfc_conv_constant (&se, c->expr);
4719 case EXPR_STRUCTURE:
4720 gfc_conv_structure (&se, c->expr, 1);
4724 /* Catch those occasional beasts that do not simplify
4725 for one reason or another, assuming that if they are
4726 standard defying the frontend will catch them. */
4727 gfc_conv_expr (&se, c->expr);
4731 if (range == NULL_TREE)
4732 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4735 if (index != NULL_TREE)
4736 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4737 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4743 return gfc_build_null_descriptor (type);
4749 /* Create a constructor from the list of elements. */
4750 tmp = build_constructor (type, v);
4751 TREE_CONSTANT (tmp) = 1;
4756 /* Generate code to evaluate non-constant coarray cobounds. */
4759 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4760 const gfc_symbol *sym)
4770 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4772 /* Evaluate non-constant array bound expressions. */
4773 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4774 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4776 gfc_init_se (&se, NULL);
4777 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4778 gfc_add_block_to_block (pblock, &se.pre);
4779 gfc_add_modify (pblock, lbound, se.expr);
4781 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4782 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4784 gfc_init_se (&se, NULL);
4785 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4786 gfc_add_block_to_block (pblock, &se.pre);
4787 gfc_add_modify (pblock, ubound, se.expr);
4793 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4794 returns the size (in elements) of the array. */
4797 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4798 stmtblock_t * pblock)
4813 size = gfc_index_one_node;
4814 offset = gfc_index_zero_node;
4815 for (dim = 0; dim < as->rank; dim++)
4817 /* Evaluate non-constant array bound expressions. */
4818 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4819 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4821 gfc_init_se (&se, NULL);
4822 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4823 gfc_add_block_to_block (pblock, &se.pre);
4824 gfc_add_modify (pblock, lbound, se.expr);
4826 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4827 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4829 gfc_init_se (&se, NULL);
4830 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4831 gfc_add_block_to_block (pblock, &se.pre);
4832 gfc_add_modify (pblock, ubound, se.expr);
4834 /* The offset of this dimension. offset = offset - lbound * stride. */
4835 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4837 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4840 /* The size of this dimension, and the stride of the next. */
4841 if (dim + 1 < as->rank)
4842 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4844 stride = GFC_TYPE_ARRAY_SIZE (type);
4846 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4848 /* Calculate stride = size * (ubound + 1 - lbound). */
4849 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4850 gfc_array_index_type,
4851 gfc_index_one_node, lbound);
4852 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4853 gfc_array_index_type, ubound, tmp);
4854 tmp = fold_build2_loc (input_location, MULT_EXPR,
4855 gfc_array_index_type, size, tmp);
4857 gfc_add_modify (pblock, stride, tmp);
4859 stride = gfc_evaluate_now (tmp, pblock);
4861 /* Make sure that negative size arrays are translated
4862 to being zero size. */
4863 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4864 stride, gfc_index_zero_node);
4865 tmp = fold_build3_loc (input_location, COND_EXPR,
4866 gfc_array_index_type, tmp,
4867 stride, gfc_index_zero_node);
4868 gfc_add_modify (pblock, stride, tmp);
4874 gfc_trans_array_cobounds (type, pblock, sym);
4875 gfc_trans_vla_type_sizes (sym, pblock);
4882 /* Generate code to initialize/allocate an array variable. */
4885 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4886 gfc_wrapped_block * block)
4890 tree tmp = NULL_TREE;
4897 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4899 /* Do nothing for USEd variables. */
4900 if (sym->attr.use_assoc)
4903 type = TREE_TYPE (decl);
4904 gcc_assert (GFC_ARRAY_TYPE_P (type));
4905 onstack = TREE_CODE (type) != POINTER_TYPE;
4907 gfc_init_block (&init);
4909 /* Evaluate character string length. */
4910 if (sym->ts.type == BT_CHARACTER
4911 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4913 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4915 gfc_trans_vla_type_sizes (sym, &init);
4917 /* Emit a DECL_EXPR for this variable, which will cause the
4918 gimplifier to allocate storage, and all that good stuff. */
4919 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4920 gfc_add_expr_to_block (&init, tmp);
4925 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4929 type = TREE_TYPE (type);
4931 gcc_assert (!sym->attr.use_assoc);
4932 gcc_assert (!TREE_STATIC (decl));
4933 gcc_assert (!sym->module);
4935 if (sym->ts.type == BT_CHARACTER
4936 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4937 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4939 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4941 /* Don't actually allocate space for Cray Pointees. */
4942 if (sym->attr.cray_pointee)
4944 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4945 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4947 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4951 if (gfc_option.flag_stack_arrays)
4953 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
4954 space = build_decl (sym->declared_at.lb->location,
4955 VAR_DECL, create_tmp_var_name ("A"),
4956 TREE_TYPE (TREE_TYPE (decl)));
4957 gfc_trans_vla_type_sizes (sym, &init);
4961 /* The size is the number of elements in the array, so multiply by the
4962 size of an element to get the total size. */
4963 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4964 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4965 size, fold_convert (gfc_array_index_type, tmp));
4967 /* Allocate memory to hold the data. */
4968 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4969 gfc_add_modify (&init, decl, tmp);
4971 /* Free the temporary. */
4972 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4976 /* Set offset of the array. */
4977 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4978 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4980 /* Automatic arrays should not have initializers. */
4981 gcc_assert (!sym->value);
4983 inittree = gfc_finish_block (&init);
4990 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
4991 where also space is located. */
4992 gfc_init_block (&init);
4993 tmp = fold_build1_loc (input_location, DECL_EXPR,
4994 TREE_TYPE (space), space);
4995 gfc_add_expr_to_block (&init, tmp);
4996 addr = fold_build1_loc (sym->declared_at.lb->location,
4997 ADDR_EXPR, TREE_TYPE (decl), space);
4998 gfc_add_modify (&init, decl, addr);
4999 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5002 gfc_add_init_cleanup (block, inittree, tmp);
5006 /* Generate entry and exit code for g77 calling convention arrays. */
5009 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5019 gfc_save_backend_locus (&loc);
5020 gfc_set_backend_locus (&sym->declared_at);
5022 /* Descriptor type. */
5023 parm = sym->backend_decl;
5024 type = TREE_TYPE (parm);
5025 gcc_assert (GFC_ARRAY_TYPE_P (type));
5027 gfc_start_block (&init);
5029 if (sym->ts.type == BT_CHARACTER
5030 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5031 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5033 /* Evaluate the bounds of the array. */
5034 gfc_trans_array_bounds (type, sym, &offset, &init);
5036 /* Set the offset. */
5037 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5038 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5040 /* Set the pointer itself if we aren't using the parameter directly. */
5041 if (TREE_CODE (parm) != PARM_DECL)
5043 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5044 gfc_add_modify (&init, parm, tmp);
5046 stmt = gfc_finish_block (&init);
5048 gfc_restore_backend_locus (&loc);
5050 /* Add the initialization code to the start of the function. */
5052 if (sym->attr.optional || sym->attr.not_always_present)
5054 tmp = gfc_conv_expr_present (sym);
5055 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5058 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5062 /* Modify the descriptor of an array parameter so that it has the
5063 correct lower bound. Also move the upper bound accordingly.
5064 If the array is not packed, it will be copied into a temporary.
5065 For each dimension we set the new lower and upper bounds. Then we copy the
5066 stride and calculate the offset for this dimension. We also work out
5067 what the stride of a packed array would be, and see it the two match.
5068 If the array need repacking, we set the stride to the values we just
5069 calculated, recalculate the offset and copy the array data.
5070 Code is also added to copy the data back at the end of the function.
5074 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5075 gfc_wrapped_block * block)
5082 tree stmtInit, stmtCleanup;
5089 tree stride, stride2;
5099 /* Do nothing for pointer and allocatable arrays. */
5100 if (sym->attr.pointer || sym->attr.allocatable)
5103 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5105 gfc_trans_g77_array (sym, block);
5109 gfc_save_backend_locus (&loc);
5110 gfc_set_backend_locus (&sym->declared_at);
5112 /* Descriptor type. */
5113 type = TREE_TYPE (tmpdesc);
5114 gcc_assert (GFC_ARRAY_TYPE_P (type));
5115 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5116 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5117 gfc_start_block (&init);
5119 if (sym->ts.type == BT_CHARACTER
5120 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5121 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5123 checkparm = (sym->as->type == AS_EXPLICIT
5124 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5126 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5127 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5129 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5131 /* For non-constant shape arrays we only check if the first dimension
5132 is contiguous. Repacking higher dimensions wouldn't gain us
5133 anything as we still don't know the array stride. */
5134 partial = gfc_create_var (boolean_type_node, "partial");
5135 TREE_USED (partial) = 1;
5136 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5137 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5138 gfc_index_one_node);
5139 gfc_add_modify (&init, partial, tmp);
5142 partial = NULL_TREE;
5144 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5145 here, however I think it does the right thing. */
5148 /* Set the first stride. */
5149 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5150 stride = gfc_evaluate_now (stride, &init);
5152 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5153 stride, gfc_index_zero_node);
5154 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5155 tmp, gfc_index_one_node, stride);
5156 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5157 gfc_add_modify (&init, stride, tmp);
5159 /* Allow the user to disable array repacking. */
5160 stmt_unpacked = NULL_TREE;
5164 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5165 /* A library call to repack the array if necessary. */
5166 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5167 stmt_unpacked = build_call_expr_loc (input_location,
5168 gfor_fndecl_in_pack, 1, tmp);
5170 stride = gfc_index_one_node;
5172 if (gfc_option.warn_array_temp)
5173 gfc_warning ("Creating array temporary at %L", &loc);
5176 /* This is for the case where the array data is used directly without
5177 calling the repack function. */
5178 if (no_repack || partial != NULL_TREE)
5179 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5181 stmt_packed = NULL_TREE;
5183 /* Assign the data pointer. */
5184 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5186 /* Don't repack unknown shape arrays when the first stride is 1. */
5187 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5188 partial, stmt_packed, stmt_unpacked);
5191 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5192 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5194 offset = gfc_index_zero_node;
5195 size = gfc_index_one_node;
5197 /* Evaluate the bounds of the array. */
5198 for (n = 0; n < sym->as->rank; n++)
5200 if (checkparm || !sym->as->upper[n])
5202 /* Get the bounds of the actual parameter. */
5203 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5204 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5208 dubound = NULL_TREE;
5209 dlbound = NULL_TREE;
5212 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5213 if (!INTEGER_CST_P (lbound))
5215 gfc_init_se (&se, NULL);
5216 gfc_conv_expr_type (&se, sym->as->lower[n],
5217 gfc_array_index_type);
5218 gfc_add_block_to_block (&init, &se.pre);
5219 gfc_add_modify (&init, lbound, se.expr);
5222 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5223 /* Set the desired upper bound. */
5224 if (sym->as->upper[n])
5226 /* We know what we want the upper bound to be. */
5227 if (!INTEGER_CST_P (ubound))
5229 gfc_init_se (&se, NULL);
5230 gfc_conv_expr_type (&se, sym->as->upper[n],
5231 gfc_array_index_type);
5232 gfc_add_block_to_block (&init, &se.pre);
5233 gfc_add_modify (&init, ubound, se.expr);
5236 /* Check the sizes match. */
5239 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5243 temp = fold_build2_loc (input_location, MINUS_EXPR,
5244 gfc_array_index_type, ubound, lbound);
5245 temp = fold_build2_loc (input_location, PLUS_EXPR,
5246 gfc_array_index_type,
5247 gfc_index_one_node, temp);
5248 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5249 gfc_array_index_type, dubound,
5251 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5252 gfc_array_index_type,
5253 gfc_index_one_node, stride2);
5254 tmp = fold_build2_loc (input_location, NE_EXPR,
5255 gfc_array_index_type, temp, stride2);
5256 asprintf (&msg, "Dimension %d of array '%s' has extent "
5257 "%%ld instead of %%ld", n+1, sym->name);
5259 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5260 fold_convert (long_integer_type_node, temp),
5261 fold_convert (long_integer_type_node, stride2));
5268 /* For assumed shape arrays move the upper bound by the same amount
5269 as the lower bound. */
5270 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5271 gfc_array_index_type, dubound, dlbound);
5272 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5273 gfc_array_index_type, tmp, lbound);
5274 gfc_add_modify (&init, ubound, tmp);
5276 /* The offset of this dimension. offset = offset - lbound * stride. */
5277 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5279 offset = fold_build2_loc (input_location, MINUS_EXPR,
5280 gfc_array_index_type, offset, tmp);
5282 /* The size of this dimension, and the stride of the next. */
5283 if (n + 1 < sym->as->rank)
5285 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5287 if (no_repack || partial != NULL_TREE)
5289 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5291 /* Figure out the stride if not a known constant. */
5292 if (!INTEGER_CST_P (stride))
5295 stmt_packed = NULL_TREE;
5298 /* Calculate stride = size * (ubound + 1 - lbound). */
5299 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5300 gfc_array_index_type,
5301 gfc_index_one_node, lbound);
5302 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5303 gfc_array_index_type, ubound, tmp);
5304 size = fold_build2_loc (input_location, MULT_EXPR,
5305 gfc_array_index_type, size, tmp);
5309 /* Assign the stride. */
5310 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5311 tmp = fold_build3_loc (input_location, COND_EXPR,
5312 gfc_array_index_type, partial,
5313 stmt_unpacked, stmt_packed);
5315 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5316 gfc_add_modify (&init, stride, tmp);
5321 stride = GFC_TYPE_ARRAY_SIZE (type);
5323 if (stride && !INTEGER_CST_P (stride))
5325 /* Calculate size = stride * (ubound + 1 - lbound). */
5326 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5327 gfc_array_index_type,
5328 gfc_index_one_node, lbound);
5329 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5330 gfc_array_index_type,
5332 tmp = fold_build2_loc (input_location, MULT_EXPR,
5333 gfc_array_index_type,
5334 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5335 gfc_add_modify (&init, stride, tmp);
5340 gfc_trans_array_cobounds (type, &init, sym);
5342 /* Set the offset. */
5343 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5344 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5346 gfc_trans_vla_type_sizes (sym, &init);
5348 stmtInit = gfc_finish_block (&init);
5350 /* Only do the entry/initialization code if the arg is present. */
5351 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5352 optional_arg = (sym->attr.optional
5353 || (sym->ns->proc_name->attr.entry_master
5354 && sym->attr.dummy));
5357 tmp = gfc_conv_expr_present (sym);
5358 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5359 build_empty_stmt (input_location));
5364 stmtCleanup = NULL_TREE;
5367 stmtblock_t cleanup;
5368 gfc_start_block (&cleanup);
5370 if (sym->attr.intent != INTENT_IN)
5372 /* Copy the data back. */
5373 tmp = build_call_expr_loc (input_location,
5374 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5375 gfc_add_expr_to_block (&cleanup, tmp);
5378 /* Free the temporary. */
5379 tmp = gfc_call_free (tmpdesc);
5380 gfc_add_expr_to_block (&cleanup, tmp);
5382 stmtCleanup = gfc_finish_block (&cleanup);
5384 /* Only do the cleanup if the array was repacked. */
5385 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5386 tmp = gfc_conv_descriptor_data_get (tmp);
5387 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5389 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5390 build_empty_stmt (input_location));
5394 tmp = gfc_conv_expr_present (sym);
5395 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5396 build_empty_stmt (input_location));
5400 /* We don't need to free any memory allocated by internal_pack as it will
5401 be freed at the end of the function by pop_context. */
5402 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5404 gfc_restore_backend_locus (&loc);
5408 /* Calculate the overall offset, including subreferences. */
5410 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5411 bool subref, gfc_expr *expr)
5421 /* If offset is NULL and this is not a subreferenced array, there is
5423 if (offset == NULL_TREE)
5426 offset = gfc_index_zero_node;
5431 tmp = gfc_conv_array_data (desc);
5432 tmp = build_fold_indirect_ref_loc (input_location,
5434 tmp = gfc_build_array_ref (tmp, offset, NULL);
5436 /* Offset the data pointer for pointer assignments from arrays with
5437 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5440 /* Go past the array reference. */
5441 for (ref = expr->ref; ref; ref = ref->next)
5442 if (ref->type == REF_ARRAY &&
5443 ref->u.ar.type != AR_ELEMENT)
5449 /* Calculate the offset for each subsequent subreference. */
5450 for (; ref; ref = ref->next)
5455 field = ref->u.c.component->backend_decl;
5456 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5457 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5459 tmp, field, NULL_TREE);
5463 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5464 gfc_init_se (&start, NULL);
5465 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5466 gfc_add_block_to_block (block, &start.pre);
5467 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5471 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5472 && ref->u.ar.type == AR_ELEMENT);
5474 /* TODO - Add bounds checking. */
5475 stride = gfc_index_one_node;
5476 index = gfc_index_zero_node;
5477 for (n = 0; n < ref->u.ar.dimen; n++)
5482 /* Update the index. */
5483 gfc_init_se (&start, NULL);
5484 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5485 itmp = gfc_evaluate_now (start.expr, block);
5486 gfc_init_se (&start, NULL);
5487 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5488 jtmp = gfc_evaluate_now (start.expr, block);
5489 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5490 gfc_array_index_type, itmp, jtmp);
5491 itmp = fold_build2_loc (input_location, MULT_EXPR,
5492 gfc_array_index_type, itmp, stride);
5493 index = fold_build2_loc (input_location, PLUS_EXPR,
5494 gfc_array_index_type, itmp, index);
5495 index = gfc_evaluate_now (index, block);
5497 /* Update the stride. */
5498 gfc_init_se (&start, NULL);
5499 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5500 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5501 gfc_array_index_type, start.expr,
5503 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5504 gfc_array_index_type,
5505 gfc_index_one_node, itmp);
5506 stride = fold_build2_loc (input_location, MULT_EXPR,
5507 gfc_array_index_type, stride, itmp);
5508 stride = gfc_evaluate_now (stride, block);
5511 /* Apply the index to obtain the array element. */
5512 tmp = gfc_build_array_ref (tmp, index, NULL);
5522 /* Set the target data pointer. */
5523 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5524 gfc_conv_descriptor_data_set (block, parm, offset);
5528 /* gfc_conv_expr_descriptor needs the string length an expression
5529 so that the size of the temporary can be obtained. This is done
5530 by adding up the string lengths of all the elements in the
5531 expression. Function with non-constant expressions have their
5532 string lengths mapped onto the actual arguments using the
5533 interface mapping machinery in trans-expr.c. */
5535 get_array_charlen (gfc_expr *expr, gfc_se *se)
5537 gfc_interface_mapping mapping;
5538 gfc_formal_arglist *formal;
5539 gfc_actual_arglist *arg;
5542 if (expr->ts.u.cl->length
5543 && gfc_is_constant_expr (expr->ts.u.cl->length))
5545 if (!expr->ts.u.cl->backend_decl)
5546 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5550 switch (expr->expr_type)
5553 get_array_charlen (expr->value.op.op1, se);
5555 /* For parentheses the expression ts.u.cl is identical. */
5556 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5559 expr->ts.u.cl->backend_decl =
5560 gfc_create_var (gfc_charlen_type_node, "sln");
5562 if (expr->value.op.op2)
5564 get_array_charlen (expr->value.op.op2, se);
5566 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5568 /* Add the string lengths and assign them to the expression
5569 string length backend declaration. */
5570 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5571 fold_build2_loc (input_location, PLUS_EXPR,
5572 gfc_charlen_type_node,
5573 expr->value.op.op1->ts.u.cl->backend_decl,
5574 expr->value.op.op2->ts.u.cl->backend_decl));
5577 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5578 expr->value.op.op1->ts.u.cl->backend_decl);
5582 if (expr->value.function.esym == NULL
5583 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5585 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5589 /* Map expressions involving the dummy arguments onto the actual
5590 argument expressions. */
5591 gfc_init_interface_mapping (&mapping);
5592 formal = expr->symtree->n.sym->formal;
5593 arg = expr->value.function.actual;
5595 /* Set se = NULL in the calls to the interface mapping, to suppress any
5597 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5602 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5605 gfc_init_se (&tse, NULL);
5607 /* Build the expression for the character length and convert it. */
5608 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5610 gfc_add_block_to_block (&se->pre, &tse.pre);
5611 gfc_add_block_to_block (&se->post, &tse.post);
5612 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5613 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5614 gfc_charlen_type_node, tse.expr,
5615 build_int_cst (gfc_charlen_type_node, 0));
5616 expr->ts.u.cl->backend_decl = tse.expr;
5617 gfc_free_interface_mapping (&mapping);
5621 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5626 /* Helper function to check dimensions. */
5628 dim_ok (gfc_ss_info *info)
5631 for (n = 0; n < info->dimen; n++)
5632 if (info->dim[n] != n)
5637 /* Convert an array for passing as an actual argument. Expressions and
5638 vector subscripts are evaluated and stored in a temporary, which is then
5639 passed. For whole arrays the descriptor is passed. For array sections
5640 a modified copy of the descriptor is passed, but using the original data.
5642 This function is also used for array pointer assignments, and there
5645 - se->want_pointer && !se->direct_byref
5646 EXPR is an actual argument. On exit, se->expr contains a
5647 pointer to the array descriptor.
5649 - !se->want_pointer && !se->direct_byref
5650 EXPR is an actual argument to an intrinsic function or the
5651 left-hand side of a pointer assignment. On exit, se->expr
5652 contains the descriptor for EXPR.
5654 - !se->want_pointer && se->direct_byref
5655 EXPR is the right-hand side of a pointer assignment and
5656 se->expr is the descriptor for the previously-evaluated
5657 left-hand side. The function creates an assignment from
5661 The se->force_tmp flag disables the non-copying descriptor optimization
5662 that is used for transpose. It may be used in cases where there is an
5663 alias between the transpose argument and another argument in the same
5667 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5679 bool subref_array_target = false;
5682 gcc_assert (ss != NULL);
5683 gcc_assert (ss != gfc_ss_terminator);
5685 /* Special case things we know we can pass easily. */
5686 switch (expr->expr_type)
5689 /* If we have a linear array section, we can pass it directly.
5690 Otherwise we need to copy it into a temporary. */
5692 gcc_assert (ss->type == GFC_SS_SECTION);
5693 gcc_assert (ss->expr == expr);
5694 info = &ss->data.info;
5696 /* Get the descriptor for the array. */
5697 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5698 desc = info->descriptor;
5700 subref_array_target = se->direct_byref && is_subref_array (expr);
5701 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5702 && !subref_array_target;
5709 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5711 /* Create a new descriptor if the array doesn't have one. */
5714 else if (info->ref->u.ar.type == AR_FULL)
5716 else if (se->direct_byref)
5719 full = gfc_full_array_ref_p (info->ref, NULL);
5721 if (full && dim_ok (info))
5723 if (se->direct_byref && !se->byref_noassign)
5725 /* Copy the descriptor for pointer assignments. */
5726 gfc_add_modify (&se->pre, se->expr, desc);
5728 /* Add any offsets from subreferences. */
5729 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5730 subref_array_target, expr);
5732 else if (se->want_pointer)
5734 /* We pass full arrays directly. This means that pointers and
5735 allocatable arrays should also work. */
5736 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5743 if (expr->ts.type == BT_CHARACTER)
5744 se->string_length = gfc_get_expr_charlen (expr);
5752 /* We don't need to copy data in some cases. */
5753 arg = gfc_get_noncopying_intrinsic_argument (expr);
5756 /* This is a call to transpose... */
5757 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5758 /* ... which has already been handled by the scalarizer, so
5759 that we just need to get its argument's descriptor. */
5760 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5764 /* A transformational function return value will be a temporary
5765 array descriptor. We still need to go through the scalarizer
5766 to create the descriptor. Elemental functions ar handled as
5767 arbitrary expressions, i.e. copy to a temporary. */
5769 if (se->direct_byref)
5771 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5773 /* For pointer assignments pass the descriptor directly. */
5777 gcc_assert (se->ss == ss);
5778 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5779 gfc_conv_expr (se, expr);
5783 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5785 if (ss->expr != expr)
5786 /* Elemental function. */
5787 gcc_assert ((expr->value.function.esym != NULL
5788 && expr->value.function.esym->attr.elemental)
5789 || (expr->value.function.isym != NULL
5790 && expr->value.function.isym->elemental));
5792 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5795 if (expr->ts.type == BT_CHARACTER
5796 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5797 get_array_charlen (expr, se);
5803 /* Transformational function. */
5804 info = &ss->data.info;
5810 /* Constant array constructors don't need a temporary. */
5811 if (ss->type == GFC_SS_CONSTRUCTOR
5812 && expr->ts.type != BT_CHARACTER
5813 && gfc_constant_array_constructor_p (expr->value.constructor))
5816 info = &ss->data.info;
5826 /* Something complicated. Copy it into a temporary. */
5832 /* If we are creating a temporary, we don't need to bother about aliases
5837 gfc_init_loopinfo (&loop);
5839 /* Associate the SS with the loop. */
5840 gfc_add_ss_to_loop (&loop, ss);
5842 /* Tell the scalarizer not to bother creating loop variables, etc. */
5844 loop.array_parameter = 1;
5846 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5847 gcc_assert (!se->direct_byref);
5849 /* Setup the scalarizing loops and bounds. */
5850 gfc_conv_ss_startstride (&loop);
5854 /* Tell the scalarizer to make a temporary. */
5855 loop.temp_ss = gfc_get_ss ();
5856 loop.temp_ss->type = GFC_SS_TEMP;
5857 loop.temp_ss->next = gfc_ss_terminator;
5859 if (expr->ts.type == BT_CHARACTER
5860 && !expr->ts.u.cl->backend_decl)
5861 get_array_charlen (expr, se);
5863 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5865 if (expr->ts.type == BT_CHARACTER)
5866 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5868 loop.temp_ss->string_length = NULL;
5870 se->string_length = loop.temp_ss->string_length;
5871 loop.temp_ss->data.temp.dimen = loop.dimen;
5872 loop.temp_ss->data.temp.codimen = loop.codimen;
5873 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5876 gfc_conv_loop_setup (&loop, & expr->where);
5880 /* Copy into a temporary and pass that. We don't need to copy the data
5881 back because expressions and vector subscripts must be INTENT_IN. */
5882 /* TODO: Optimize passing function return values. */
5886 /* Start the copying loops. */
5887 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5888 gfc_mark_ss_chain_used (ss, 1);
5889 gfc_start_scalarized_body (&loop, &block);
5891 /* Copy each data element. */
5892 gfc_init_se (&lse, NULL);
5893 gfc_copy_loopinfo_to_se (&lse, &loop);
5894 gfc_init_se (&rse, NULL);
5895 gfc_copy_loopinfo_to_se (&rse, &loop);
5897 lse.ss = loop.temp_ss;
5900 gfc_conv_scalarized_array_ref (&lse, NULL);
5901 if (expr->ts.type == BT_CHARACTER)
5903 gfc_conv_expr (&rse, expr);
5904 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5905 rse.expr = build_fold_indirect_ref_loc (input_location,
5909 gfc_conv_expr_val (&rse, expr);
5911 gfc_add_block_to_block (&block, &rse.pre);
5912 gfc_add_block_to_block (&block, &lse.pre);
5914 lse.string_length = rse.string_length;
5915 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5916 expr->expr_type == EXPR_VARIABLE
5917 || expr->expr_type == EXPR_ARRAY, true);
5918 gfc_add_expr_to_block (&block, tmp);
5920 /* Finish the copying loops. */
5921 gfc_trans_scalarizing_loops (&loop, &block);
5923 desc = loop.temp_ss->data.info.descriptor;
5925 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5927 desc = info->descriptor;
5928 se->string_length = ss->string_length;
5932 /* We pass sections without copying to a temporary. Make a new
5933 descriptor and point it at the section we want. The loop variable
5934 limits will be the limits of the section.
5935 A function may decide to repack the array to speed up access, but
5936 we're not bothered about that here. */
5937 int dim, ndim, codim;
5945 /* Set the string_length for a character array. */
5946 if (expr->ts.type == BT_CHARACTER)
5947 se->string_length = gfc_get_expr_charlen (expr);
5949 desc = info->descriptor;
5950 if (se->direct_byref && !se->byref_noassign)
5952 /* For pointer assignments we fill in the destination. */
5954 parmtype = TREE_TYPE (parm);
5958 /* Otherwise make a new one. */
5959 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5960 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5961 loop.codimen, loop.from,
5963 GFC_ARRAY_UNKNOWN, false);
5964 parm = gfc_create_var (parmtype, "parm");
5967 offset = gfc_index_zero_node;
5969 /* The following can be somewhat confusing. We have two
5970 descriptors, a new one and the original array.
5971 {parm, parmtype, dim} refer to the new one.
5972 {desc, type, n, loop} refer to the original, which maybe
5973 a descriptorless array.
5974 The bounds of the scalarization are the bounds of the section.
5975 We don't have to worry about numeric overflows when calculating
5976 the offsets because all elements are within the array data. */
5978 /* Set the dtype. */
5979 tmp = gfc_conv_descriptor_dtype (parm);
5980 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5982 /* Set offset for assignments to pointer only to zero if it is not
5984 if (se->direct_byref
5985 && info->ref && info->ref->u.ar.type != AR_FULL)
5986 base = gfc_index_zero_node;
5987 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5988 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5992 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5993 codim = info->codimen;
5994 for (n = 0; n < ndim; n++)
5996 stride = gfc_conv_array_stride (desc, n);
5998 /* Work out the offset. */
6000 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6002 gcc_assert (info->subscript[n]
6003 && info->subscript[n]->type == GFC_SS_SCALAR);
6004 start = info->subscript[n]->data.scalar.expr;
6008 /* Evaluate and remember the start of the section. */
6009 start = info->start[n];
6010 stride = gfc_evaluate_now (stride, &loop.pre);
6013 tmp = gfc_conv_array_lbound (desc, n);
6014 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6016 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6018 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6022 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6024 /* For elemental dimensions, we only need the offset. */
6028 /* Vector subscripts need copying and are handled elsewhere. */
6030 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6032 /* look for the corresponding scalarizer dimension: dim. */
6033 for (dim = 0; dim < ndim; dim++)
6034 if (info->dim[dim] == n)
6037 /* loop exited early: the DIM being looked for has been found. */
6038 gcc_assert (dim < ndim);
6040 /* Set the new lower bound. */
6041 from = loop.from[dim];
6044 /* If we have an array section or are assigning make sure that
6045 the lower bound is 1. References to the full
6046 array should otherwise keep the original bounds. */
6048 || info->ref->u.ar.type != AR_FULL)
6049 && !integer_onep (from))
6051 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6052 gfc_array_index_type, gfc_index_one_node,
6054 to = fold_build2_loc (input_location, PLUS_EXPR,
6055 gfc_array_index_type, to, tmp);
6056 from = gfc_index_one_node;
6058 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6059 gfc_rank_cst[dim], from);
6061 /* Set the new upper bound. */
6062 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6063 gfc_rank_cst[dim], to);
6065 /* Multiply the stride by the section stride to get the
6067 stride = fold_build2_loc (input_location, MULT_EXPR,
6068 gfc_array_index_type,
6069 stride, info->stride[n]);
6071 if (se->direct_byref
6073 && info->ref->u.ar.type != AR_FULL)
6075 base = fold_build2_loc (input_location, MINUS_EXPR,
6076 TREE_TYPE (base), base, stride);
6078 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6080 tmp = gfc_conv_array_lbound (desc, n);
6081 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6082 TREE_TYPE (base), tmp, loop.from[dim]);
6083 tmp = fold_build2_loc (input_location, MULT_EXPR,
6084 TREE_TYPE (base), tmp,
6085 gfc_conv_array_stride (desc, n));
6086 base = fold_build2_loc (input_location, PLUS_EXPR,
6087 TREE_TYPE (base), tmp, base);
6090 /* Store the new stride. */
6091 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6092 gfc_rank_cst[dim], stride);
6095 for (n = ndim; n < ndim + codim; n++)
6097 /* look for the corresponding scalarizer dimension: dim. */
6098 for (dim = 0; dim < ndim + codim; dim++)
6099 if (info->dim[dim] == n)
6102 /* loop exited early: the DIM being looked for has been found. */
6103 gcc_assert (dim < ndim + codim);
6105 from = loop.from[dim];
6107 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6108 gfc_rank_cst[dim], from);
6109 if (n < ndim + codim - 1)
6110 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6111 gfc_rank_cst[dim], to);
6115 if (se->data_not_needed)
6116 gfc_conv_descriptor_data_set (&loop.pre, parm,
6117 gfc_index_zero_node);
6119 /* Point the data pointer at the 1st element in the section. */
6120 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6121 subref_array_target, expr);
6123 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6124 && !se->data_not_needed)
6126 /* Set the offset. */
6127 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6131 /* Only the callee knows what the correct offset it, so just set
6133 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6138 if (!se->direct_byref || se->byref_noassign)
6140 /* Get a pointer to the new descriptor. */
6141 if (se->want_pointer)
6142 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6147 gfc_add_block_to_block (&se->pre, &loop.pre);
6148 gfc_add_block_to_block (&se->post, &loop.post);
6150 /* Cleanup the scalarizer. */
6151 gfc_cleanup_loop (&loop);
6154 /* Helper function for gfc_conv_array_parameter if array size needs to be
6158 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6161 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6162 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6163 else if (expr->rank > 1)
6164 *size = build_call_expr_loc (input_location,
6165 gfor_fndecl_size0, 1,
6166 gfc_build_addr_expr (NULL, desc));
6169 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6170 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6172 *size = fold_build2_loc (input_location, MINUS_EXPR,
6173 gfc_array_index_type, ubound, lbound);
6174 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6175 *size, gfc_index_one_node);
6176 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6177 *size, gfc_index_zero_node);
6179 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6180 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6181 *size, fold_convert (gfc_array_index_type, elem));
6184 /* Convert an array for passing as an actual parameter. */
6185 /* TODO: Optimize passing g77 arrays. */
6188 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6189 const gfc_symbol *fsym, const char *proc_name,
6194 tree tmp = NULL_TREE;
6196 tree parent = DECL_CONTEXT (current_function_decl);
6197 bool full_array_var;
6198 bool this_array_result;
6201 bool array_constructor;
6202 bool good_allocatable;
6203 bool ultimate_ptr_comp;
6204 bool ultimate_alloc_comp;
6209 ultimate_ptr_comp = false;
6210 ultimate_alloc_comp = false;
6212 for (ref = expr->ref; ref; ref = ref->next)
6214 if (ref->next == NULL)
6217 if (ref->type == REF_COMPONENT)
6219 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6220 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6224 full_array_var = false;
6227 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6228 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6230 sym = full_array_var ? expr->symtree->n.sym : NULL;
6232 /* The symbol should have an array specification. */
6233 gcc_assert (!sym || sym->as || ref->u.ar.as);
6235 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6237 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6238 expr->ts.u.cl->backend_decl = tmp;
6239 se->string_length = tmp;
6242 /* Is this the result of the enclosing procedure? */
6243 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6244 if (this_array_result
6245 && (sym->backend_decl != current_function_decl)
6246 && (sym->backend_decl != parent))
6247 this_array_result = false;
6249 /* Passing address of the array if it is not pointer or assumed-shape. */
6250 if (full_array_var && g77 && !this_array_result)
6252 tmp = gfc_get_symbol_decl (sym);
6254 if (sym->ts.type == BT_CHARACTER)
6255 se->string_length = sym->ts.u.cl->backend_decl;
6257 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6259 gfc_conv_expr_descriptor (se, expr, ss);
6260 se->expr = gfc_conv_array_data (se->expr);
6264 if (!sym->attr.pointer
6266 && sym->as->type != AS_ASSUMED_SHAPE
6267 && !sym->attr.allocatable)
6269 /* Some variables are declared directly, others are declared as
6270 pointers and allocated on the heap. */
6271 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6274 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6276 array_parameter_size (tmp, expr, size);
6280 if (sym->attr.allocatable)
6282 if (sym->attr.dummy || sym->attr.result)
6284 gfc_conv_expr_descriptor (se, expr, ss);
6288 array_parameter_size (tmp, expr, size);
6289 se->expr = gfc_conv_array_data (tmp);
6294 /* A convenient reduction in scope. */
6295 contiguous = g77 && !this_array_result && contiguous;
6297 /* There is no need to pack and unpack the array, if it is contiguous
6298 and not a deferred- or assumed-shape array, or if it is simply
6300 no_pack = ((sym && sym->as
6301 && !sym->attr.pointer
6302 && sym->as->type != AS_DEFERRED
6303 && sym->as->type != AS_ASSUMED_SHAPE)
6305 (ref && ref->u.ar.as
6306 && ref->u.ar.as->type != AS_DEFERRED
6307 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6309 gfc_is_simply_contiguous (expr, false));
6311 no_pack = contiguous && no_pack;
6313 /* Array constructors are always contiguous and do not need packing. */
6314 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6316 /* Same is true of contiguous sections from allocatable variables. */
6317 good_allocatable = contiguous
6319 && expr->symtree->n.sym->attr.allocatable;
6321 /* Or ultimate allocatable components. */
6322 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6324 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6326 gfc_conv_expr_descriptor (se, expr, ss);
6327 if (expr->ts.type == BT_CHARACTER)
6328 se->string_length = expr->ts.u.cl->backend_decl;
6330 array_parameter_size (se->expr, expr, size);
6331 se->expr = gfc_conv_array_data (se->expr);
6335 if (this_array_result)
6337 /* Result of the enclosing function. */
6338 gfc_conv_expr_descriptor (se, expr, ss);
6340 array_parameter_size (se->expr, expr, size);
6341 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6343 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6344 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6345 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6352 /* Every other type of array. */
6353 se->want_pointer = 1;
6354 gfc_conv_expr_descriptor (se, expr, ss);
6356 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6361 /* Deallocate the allocatable components of structures that are
6363 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6364 && expr->ts.u.derived->attr.alloc_comp
6365 && expr->expr_type != EXPR_VARIABLE)
6367 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6368 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6370 /* The components shall be deallocated before their containing entity. */
6371 gfc_prepend_expr_to_block (&se->post, tmp);
6374 if (g77 || (fsym && fsym->attr.contiguous
6375 && !gfc_is_simply_contiguous (expr, false)))
6377 tree origptr = NULL_TREE;
6381 /* For contiguous arrays, save the original value of the descriptor. */
6384 origptr = gfc_create_var (pvoid_type_node, "origptr");
6385 tmp = build_fold_indirect_ref_loc (input_location, desc);
6386 tmp = gfc_conv_array_data (tmp);
6387 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6388 TREE_TYPE (origptr), origptr,
6389 fold_convert (TREE_TYPE (origptr), tmp));
6390 gfc_add_expr_to_block (&se->pre, tmp);
6393 /* Repack the array. */
6394 if (gfc_option.warn_array_temp)
6397 gfc_warning ("Creating array temporary at %L for argument '%s'",
6398 &expr->where, fsym->name);
6400 gfc_warning ("Creating array temporary at %L", &expr->where);
6403 ptr = build_call_expr_loc (input_location,
6404 gfor_fndecl_in_pack, 1, desc);
6406 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6408 tmp = gfc_conv_expr_present (sym);
6409 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6410 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6411 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6414 ptr = gfc_evaluate_now (ptr, &se->pre);
6416 /* Use the packed data for the actual argument, except for contiguous arrays,
6417 where the descriptor's data component is set. */
6422 tmp = build_fold_indirect_ref_loc (input_location, desc);
6423 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6426 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6430 if (fsym && proc_name)
6431 asprintf (&msg, "An array temporary was created for argument "
6432 "'%s' of procedure '%s'", fsym->name, proc_name);
6434 asprintf (&msg, "An array temporary was created");
6436 tmp = build_fold_indirect_ref_loc (input_location,
6438 tmp = gfc_conv_array_data (tmp);
6439 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6440 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6442 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6443 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6445 gfc_conv_expr_present (sym), tmp);
6447 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6452 gfc_start_block (&block);
6454 /* Copy the data back. */
6455 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6457 tmp = build_call_expr_loc (input_location,
6458 gfor_fndecl_in_unpack, 2, desc, ptr);
6459 gfc_add_expr_to_block (&block, tmp);
6462 /* Free the temporary. */
6463 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6464 gfc_add_expr_to_block (&block, tmp);
6466 stmt = gfc_finish_block (&block);
6468 gfc_init_block (&block);
6469 /* Only if it was repacked. This code needs to be executed before the
6470 loop cleanup code. */
6471 tmp = build_fold_indirect_ref_loc (input_location,
6473 tmp = gfc_conv_array_data (tmp);
6474 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6475 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6477 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6478 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6480 gfc_conv_expr_present (sym), tmp);
6482 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6484 gfc_add_expr_to_block (&block, tmp);
6485 gfc_add_block_to_block (&block, &se->post);
6487 gfc_init_block (&se->post);
6489 /* Reset the descriptor pointer. */
6492 tmp = build_fold_indirect_ref_loc (input_location, desc);
6493 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6496 gfc_add_block_to_block (&se->post, &block);
6501 /* Generate code to deallocate an array, if it is allocated. */
6504 gfc_trans_dealloc_allocated (tree descriptor)
6510 gfc_start_block (&block);
6512 var = gfc_conv_descriptor_data_get (descriptor);
6515 /* Call array_deallocate with an int * present in the second argument.
6516 Although it is ignored here, it's presence ensures that arrays that
6517 are already deallocated are ignored. */
6518 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6519 gfc_add_expr_to_block (&block, tmp);
6521 /* Zero the data pointer. */
6522 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6523 var, build_int_cst (TREE_TYPE (var), 0));
6524 gfc_add_expr_to_block (&block, tmp);
6526 return gfc_finish_block (&block);
6530 /* This helper function calculates the size in words of a full array. */
6533 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6538 idx = gfc_rank_cst[rank - 1];
6539 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6540 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6541 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6543 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6544 tmp, gfc_index_one_node);
6545 tmp = gfc_evaluate_now (tmp, block);
6547 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6548 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6550 return gfc_evaluate_now (tmp, block);
6554 /* Allocate dest to the same size as src, and copy src -> dest.
6555 If no_malloc is set, only the copy is done. */
6558 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6568 /* If the source is null, set the destination to null. Then,
6569 allocate memory to the destination. */
6570 gfc_init_block (&block);
6574 tmp = null_pointer_node;
6575 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6576 gfc_add_expr_to_block (&block, tmp);
6577 null_data = gfc_finish_block (&block);
6579 gfc_init_block (&block);
6580 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6583 tmp = gfc_call_malloc (&block, type, size);
6584 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6585 dest, fold_convert (type, tmp));
6586 gfc_add_expr_to_block (&block, tmp);
6589 tmp = built_in_decls[BUILT_IN_MEMCPY];
6590 tmp = build_call_expr_loc (input_location, tmp, 3,
6595 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6596 null_data = gfc_finish_block (&block);
6598 gfc_init_block (&block);
6599 nelems = get_full_array_size (&block, src, rank);
6600 tmp = fold_convert (gfc_array_index_type,
6601 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6602 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6606 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6607 tmp = gfc_call_malloc (&block, tmp, size);
6608 gfc_conv_descriptor_data_set (&block, dest, tmp);
6611 /* We know the temporary and the value will be the same length,
6612 so can use memcpy. */
6613 tmp = built_in_decls[BUILT_IN_MEMCPY];
6614 tmp = build_call_expr_loc (input_location,
6615 tmp, 3, gfc_conv_descriptor_data_get (dest),
6616 gfc_conv_descriptor_data_get (src), size);
6619 gfc_add_expr_to_block (&block, tmp);
6620 tmp = gfc_finish_block (&block);
6622 /* Null the destination if the source is null; otherwise do
6623 the allocate and copy. */
6627 null_cond = gfc_conv_descriptor_data_get (src);
6629 null_cond = convert (pvoid_type_node, null_cond);
6630 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6631 null_cond, null_pointer_node);
6632 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6636 /* Allocate dest to the same size as src, and copy data src -> dest. */
6639 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6641 return duplicate_allocatable (dest, src, type, rank, false);
6645 /* Copy data src -> dest. */
6648 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6650 return duplicate_allocatable (dest, src, type, rank, true);
6654 /* Recursively traverse an object of derived type, generating code to
6655 deallocate, nullify or copy allocatable components. This is the work horse
6656 function for the functions named in this enum. */
6658 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6659 COPY_ONLY_ALLOC_COMP};
6662 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6663 tree dest, int rank, int purpose)
6667 stmtblock_t fnblock;
6668 stmtblock_t loopbody;
6679 tree null_cond = NULL_TREE;
6681 gfc_init_block (&fnblock);
6683 decl_type = TREE_TYPE (decl);
6685 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6686 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6688 decl = build_fold_indirect_ref_loc (input_location,
6691 /* Just in case in gets dereferenced. */
6692 decl_type = TREE_TYPE (decl);
6694 /* If this an array of derived types with allocatable components
6695 build a loop and recursively call this function. */
6696 if (TREE_CODE (decl_type) == ARRAY_TYPE
6697 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6699 tmp = gfc_conv_array_data (decl);
6700 var = build_fold_indirect_ref_loc (input_location,
6703 /* Get the number of elements - 1 and set the counter. */
6704 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6706 /* Use the descriptor for an allocatable array. Since this
6707 is a full array reference, we only need the descriptor
6708 information from dimension = rank. */
6709 tmp = get_full_array_size (&fnblock, decl, rank);
6710 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6711 gfc_array_index_type, tmp,
6712 gfc_index_one_node);
6714 null_cond = gfc_conv_descriptor_data_get (decl);
6715 null_cond = fold_build2_loc (input_location, NE_EXPR,
6716 boolean_type_node, null_cond,
6717 build_int_cst (TREE_TYPE (null_cond), 0));
6721 /* Otherwise use the TYPE_DOMAIN information. */
6722 tmp = array_type_nelts (decl_type);
6723 tmp = fold_convert (gfc_array_index_type, tmp);
6726 /* Remember that this is, in fact, the no. of elements - 1. */
6727 nelems = gfc_evaluate_now (tmp, &fnblock);
6728 index = gfc_create_var (gfc_array_index_type, "S");
6730 /* Build the body of the loop. */
6731 gfc_init_block (&loopbody);
6733 vref = gfc_build_array_ref (var, index, NULL);
6735 if (purpose == COPY_ALLOC_COMP)
6737 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6739 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6740 gfc_add_expr_to_block (&fnblock, tmp);
6742 tmp = build_fold_indirect_ref_loc (input_location,
6743 gfc_conv_array_data (dest));
6744 dref = gfc_build_array_ref (tmp, index, NULL);
6745 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6747 else if (purpose == COPY_ONLY_ALLOC_COMP)
6749 tmp = build_fold_indirect_ref_loc (input_location,
6750 gfc_conv_array_data (dest));
6751 dref = gfc_build_array_ref (tmp, index, NULL);
6752 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6756 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6758 gfc_add_expr_to_block (&loopbody, tmp);
6760 /* Build the loop and return. */
6761 gfc_init_loopinfo (&loop);
6763 loop.from[0] = gfc_index_zero_node;
6764 loop.loopvar[0] = index;
6765 loop.to[0] = nelems;
6766 gfc_trans_scalarizing_loops (&loop, &loopbody);
6767 gfc_add_block_to_block (&fnblock, &loop.pre);
6769 tmp = gfc_finish_block (&fnblock);
6770 if (null_cond != NULL_TREE)
6771 tmp = build3_v (COND_EXPR, null_cond, tmp,
6772 build_empty_stmt (input_location));
6777 /* Otherwise, act on the components or recursively call self to
6778 act on a chain of components. */
6779 for (c = der_type->components; c; c = c->next)
6781 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6782 || c->ts.type == BT_CLASS)
6783 && c->ts.u.derived->attr.alloc_comp;
6784 cdecl = c->backend_decl;
6785 ctype = TREE_TYPE (cdecl);
6789 case DEALLOCATE_ALLOC_COMP:
6790 if (cmp_has_alloc_comps && !c->attr.pointer)
6792 /* Do not deallocate the components of ultimate pointer
6794 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6795 decl, cdecl, NULL_TREE);
6796 rank = c->as ? c->as->rank : 0;
6797 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6799 gfc_add_expr_to_block (&fnblock, tmp);
6802 if (c->attr.allocatable
6803 && (c->attr.dimension || c->attr.codimension))
6805 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6806 decl, cdecl, NULL_TREE);
6807 tmp = gfc_trans_dealloc_allocated (comp);
6808 gfc_add_expr_to_block (&fnblock, tmp);
6810 else if (c->attr.allocatable)
6812 /* Allocatable scalar components. */
6813 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6814 decl, cdecl, NULL_TREE);
6816 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6818 gfc_add_expr_to_block (&fnblock, tmp);
6820 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6821 void_type_node, comp,
6822 build_int_cst (TREE_TYPE (comp), 0));
6823 gfc_add_expr_to_block (&fnblock, tmp);
6825 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6827 /* Allocatable scalar CLASS components. */
6828 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6829 decl, cdecl, NULL_TREE);
6831 /* Add reference to '_data' component. */
6832 tmp = CLASS_DATA (c)->backend_decl;
6833 comp = fold_build3_loc (input_location, COMPONENT_REF,
6834 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6836 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6837 CLASS_DATA (c)->ts);
6838 gfc_add_expr_to_block (&fnblock, tmp);
6840 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6841 void_type_node, comp,
6842 build_int_cst (TREE_TYPE (comp), 0));
6843 gfc_add_expr_to_block (&fnblock, tmp);
6847 case NULLIFY_ALLOC_COMP:
6848 if (c->attr.pointer)
6850 else if (c->attr.allocatable
6851 && (c->attr.dimension|| c->attr.codimension))
6853 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6854 decl, cdecl, NULL_TREE);
6855 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6857 else if (c->attr.allocatable)
6859 /* Allocatable scalar components. */
6860 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6861 decl, cdecl, NULL_TREE);
6862 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6863 void_type_node, comp,
6864 build_int_cst (TREE_TYPE (comp), 0));
6865 gfc_add_expr_to_block (&fnblock, tmp);
6867 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6869 /* Allocatable scalar CLASS components. */
6870 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6871 decl, cdecl, NULL_TREE);
6872 /* Add reference to '_data' component. */
6873 tmp = CLASS_DATA (c)->backend_decl;
6874 comp = fold_build3_loc (input_location, COMPONENT_REF,
6875 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6876 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6877 void_type_node, comp,
6878 build_int_cst (TREE_TYPE (comp), 0));
6879 gfc_add_expr_to_block (&fnblock, tmp);
6881 else if (cmp_has_alloc_comps)
6883 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6884 decl, cdecl, NULL_TREE);
6885 rank = c->as ? c->as->rank : 0;
6886 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6888 gfc_add_expr_to_block (&fnblock, tmp);
6892 case COPY_ALLOC_COMP:
6893 if (c->attr.pointer)
6896 /* We need source and destination components. */
6897 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6899 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6901 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6903 if (c->attr.allocatable && !cmp_has_alloc_comps)
6905 rank = c->as ? c->as->rank : 0;
6906 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6907 gfc_add_expr_to_block (&fnblock, tmp);
6910 if (cmp_has_alloc_comps)
6912 rank = c->as ? c->as->rank : 0;
6913 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6914 gfc_add_modify (&fnblock, dcmp, tmp);
6915 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6917 gfc_add_expr_to_block (&fnblock, tmp);
6927 return gfc_finish_block (&fnblock);
6930 /* Recursively traverse an object of derived type, generating code to
6931 nullify allocatable components. */
6934 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6936 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6937 NULLIFY_ALLOC_COMP);
6941 /* Recursively traverse an object of derived type, generating code to
6942 deallocate allocatable components. */
6945 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6947 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6948 DEALLOCATE_ALLOC_COMP);
6952 /* Recursively traverse an object of derived type, generating code to
6953 copy it and its allocatable components. */
6956 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6958 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6962 /* Recursively traverse an object of derived type, generating code to
6963 copy only its allocatable components. */
6966 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6968 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6972 /* Returns the value of LBOUND for an expression. This could be broken out
6973 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6974 called by gfc_alloc_allocatable_for_assignment. */
6976 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6981 tree cond, cond1, cond3, cond4;
6985 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6987 tmp = gfc_rank_cst[dim];
6988 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6989 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6990 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6991 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6993 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6994 stride, gfc_index_zero_node);
6995 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6996 boolean_type_node, cond3, cond1);
6997 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6998 stride, gfc_index_zero_node);
7000 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7001 tmp, build_int_cst (gfc_array_index_type,
7004 cond = boolean_false_node;
7006 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7007 boolean_type_node, cond3, cond4);
7008 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7009 boolean_type_node, cond, cond1);
7011 return fold_build3_loc (input_location, COND_EXPR,
7012 gfc_array_index_type, cond,
7013 lbound, gfc_index_one_node);
7015 else if (expr->expr_type == EXPR_VARIABLE)
7017 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7018 for (ref = expr->ref; ref; ref = ref->next)
7020 if (ref->type == REF_COMPONENT
7021 && ref->u.c.component->as
7023 && ref->next->u.ar.type == AR_FULL)
7024 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7026 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7028 else if (expr->expr_type == EXPR_FUNCTION)
7030 /* A conversion function, so use the argument. */
7031 expr = expr->value.function.actual->expr;
7032 if (expr->expr_type != EXPR_VARIABLE)
7033 return gfc_index_one_node;
7034 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7035 return get_std_lbound (expr, desc, dim, assumed_size);
7038 return gfc_index_one_node;
7042 /* Returns true if an expression represents an lhs that can be reallocated
7046 gfc_is_reallocatable_lhs (gfc_expr *expr)
7053 /* An allocatable variable. */
7054 if (expr->symtree->n.sym->attr.allocatable
7056 && expr->ref->type == REF_ARRAY
7057 && expr->ref->u.ar.type == AR_FULL)
7060 /* All that can be left are allocatable components. */
7061 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7062 && expr->symtree->n.sym->ts.type != BT_CLASS)
7063 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7066 /* Find a component ref followed by an array reference. */
7067 for (ref = expr->ref; ref; ref = ref->next)
7069 && ref->type == REF_COMPONENT
7070 && ref->next->type == REF_ARRAY
7071 && !ref->next->next)
7077 /* Return true if valid reallocatable lhs. */
7078 if (ref->u.c.component->attr.allocatable
7079 && ref->next->u.ar.type == AR_FULL)
7086 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7090 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7094 stmtblock_t realloc_block;
7095 stmtblock_t alloc_block;
7118 gfc_array_spec * as;
7120 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7121 Find the lhs expression in the loop chain and set expr1 and
7122 expr2 accordingly. */
7123 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7126 /* Find the ss for the lhs. */
7128 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7129 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7131 if (lss == gfc_ss_terminator)
7136 /* Bail out if this is not a valid allocate on assignment. */
7137 if (!gfc_is_reallocatable_lhs (expr1)
7138 || (expr2 && !expr2->rank))
7141 /* Find the ss for the lhs. */
7143 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7144 if (lss->expr == expr1)
7147 if (lss == gfc_ss_terminator)
7150 /* Find an ss for the rhs. For operator expressions, we see the
7151 ss's for the operands. Any one of these will do. */
7153 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7154 if (rss->expr != expr1 && rss != loop->temp_ss)
7157 if (expr2 && rss == gfc_ss_terminator)
7160 gfc_start_block (&fblock);
7162 /* Since the lhs is allocatable, this must be a descriptor type.
7163 Get the data and array size. */
7164 desc = lss->data.info.descriptor;
7165 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7166 array1 = gfc_conv_descriptor_data_get (desc);
7168 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7169 deallocated if expr is an array of different shape or any of the
7170 corresponding length type parameter values of variable and expr
7171 differ." This assures F95 compatibility. */
7172 jump_label1 = gfc_build_label_decl (NULL_TREE);
7173 jump_label2 = gfc_build_label_decl (NULL_TREE);
7175 /* Allocate if data is NULL. */
7176 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7177 array1, build_int_cst (TREE_TYPE (array1), 0));
7178 tmp = build3_v (COND_EXPR, cond,
7179 build1_v (GOTO_EXPR, jump_label1),
7180 build_empty_stmt (input_location));
7181 gfc_add_expr_to_block (&fblock, tmp);
7183 /* Get arrayspec if expr is a full array. */
7184 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7185 && expr2->value.function.isym
7186 && expr2->value.function.isym->conversion)
7188 /* For conversion functions, take the arg. */
7189 gfc_expr *arg = expr2->value.function.actual->expr;
7190 as = gfc_get_full_arrayspec_from_expr (arg);
7193 as = gfc_get_full_arrayspec_from_expr (expr2);
7197 /* If the lhs shape is not the same as the rhs jump to setting the
7198 bounds and doing the reallocation....... */
7199 for (n = 0; n < expr1->rank; n++)
7201 /* Check the shape. */
7202 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7203 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7204 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7205 gfc_array_index_type,
7206 loop->to[n], loop->from[n]);
7207 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7208 gfc_array_index_type,
7210 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7211 gfc_array_index_type,
7213 cond = fold_build2_loc (input_location, NE_EXPR,
7215 tmp, gfc_index_zero_node);
7216 tmp = build3_v (COND_EXPR, cond,
7217 build1_v (GOTO_EXPR, jump_label1),
7218 build_empty_stmt (input_location));
7219 gfc_add_expr_to_block (&fblock, tmp);
7222 /* ....else jump past the (re)alloc code. */
7223 tmp = build1_v (GOTO_EXPR, jump_label2);
7224 gfc_add_expr_to_block (&fblock, tmp);
7226 /* Add the label to start automatic (re)allocation. */
7227 tmp = build1_v (LABEL_EXPR, jump_label1);
7228 gfc_add_expr_to_block (&fblock, tmp);
7230 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7232 /* Get the rhs size. Fix both sizes. */
7234 desc2 = rss->data.info.descriptor;
7237 size2 = gfc_index_one_node;
7238 for (n = 0; n < expr2->rank; n++)
7240 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7241 gfc_array_index_type,
7242 loop->to[n], loop->from[n]);
7243 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7244 gfc_array_index_type,
7245 tmp, gfc_index_one_node);
7246 size2 = fold_build2_loc (input_location, MULT_EXPR,
7247 gfc_array_index_type,
7251 size1 = gfc_evaluate_now (size1, &fblock);
7252 size2 = gfc_evaluate_now (size2, &fblock);
7254 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7256 neq_size = gfc_evaluate_now (cond, &fblock);
7259 /* Now modify the lhs descriptor and the associated scalarizer
7260 variables. F2003 7.4.1.3: "If variable is or becomes an
7261 unallocated allocatable variable, then it is allocated with each
7262 deferred type parameter equal to the corresponding type parameters
7263 of expr , with the shape of expr , and with each lower bound equal
7264 to the corresponding element of LBOUND(expr)."
7265 Reuse size1 to keep a dimension-by-dimension track of the
7266 stride of the new array. */
7267 size1 = gfc_index_one_node;
7268 offset = gfc_index_zero_node;
7270 for (n = 0; n < expr2->rank; n++)
7272 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7273 gfc_array_index_type,
7274 loop->to[n], loop->from[n]);
7275 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7276 gfc_array_index_type,
7277 tmp, gfc_index_one_node);
7279 lbound = gfc_index_one_node;
7284 lbd = get_std_lbound (expr2, desc2, n,
7285 as->type == AS_ASSUMED_SIZE);
7286 ubound = fold_build2_loc (input_location,
7288 gfc_array_index_type,
7290 ubound = fold_build2_loc (input_location,
7292 gfc_array_index_type,
7297 gfc_conv_descriptor_lbound_set (&fblock, desc,
7300 gfc_conv_descriptor_ubound_set (&fblock, desc,
7303 gfc_conv_descriptor_stride_set (&fblock, desc,
7306 lbound = gfc_conv_descriptor_lbound_get (desc,
7308 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7309 gfc_array_index_type,
7311 offset = fold_build2_loc (input_location, MINUS_EXPR,
7312 gfc_array_index_type,
7314 size1 = fold_build2_loc (input_location, MULT_EXPR,
7315 gfc_array_index_type,
7319 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7320 the array offset is saved and the info.offset is used for a
7321 running offset. Use the saved_offset instead. */
7322 tmp = gfc_conv_descriptor_offset (desc);
7323 gfc_add_modify (&fblock, tmp, offset);
7324 if (lss->data.info.saved_offset
7325 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7326 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7328 /* Now set the deltas for the lhs. */
7329 for (n = 0; n < expr1->rank; n++)
7331 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7332 dim = lss->data.info.dim[n];
7333 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7334 gfc_array_index_type, tmp,
7336 if (lss->data.info.delta[dim]
7337 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7338 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7341 /* Get the new lhs size in bytes. */
7342 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7344 tmp = expr2->ts.u.cl->backend_decl;
7345 gcc_assert (expr1->ts.u.cl->backend_decl);
7346 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7347 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7349 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7351 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7352 tmp = fold_build2_loc (input_location, MULT_EXPR,
7353 gfc_array_index_type, tmp,
7354 expr1->ts.u.cl->backend_decl);
7357 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7358 tmp = fold_convert (gfc_array_index_type, tmp);
7359 size2 = fold_build2_loc (input_location, MULT_EXPR,
7360 gfc_array_index_type,
7362 size2 = fold_convert (size_type_node, size2);
7363 size2 = gfc_evaluate_now (size2, &fblock);
7365 /* Realloc expression. Note that the scalarizer uses desc.data
7366 in the array reference - (*desc.data)[<element>]. */
7367 gfc_init_block (&realloc_block);
7368 tmp = build_call_expr_loc (input_location,
7369 built_in_decls[BUILT_IN_REALLOC], 2,
7370 fold_convert (pvoid_type_node, array1),
7372 gfc_conv_descriptor_data_set (&realloc_block,
7374 realloc_expr = gfc_finish_block (&realloc_block);
7376 /* Only reallocate if sizes are different. */
7377 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7378 build_empty_stmt (input_location));
7382 /* Malloc expression. */
7383 gfc_init_block (&alloc_block);
7384 tmp = build_call_expr_loc (input_location,
7385 built_in_decls[BUILT_IN_MALLOC], 1,
7387 gfc_conv_descriptor_data_set (&alloc_block,
7389 tmp = gfc_conv_descriptor_dtype (desc);
7390 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7391 alloc_expr = gfc_finish_block (&alloc_block);
7393 /* Malloc if not allocated; realloc otherwise. */
7394 tmp = build_int_cst (TREE_TYPE (array1), 0);
7395 cond = fold_build2_loc (input_location, EQ_EXPR,
7398 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7399 gfc_add_expr_to_block (&fblock, tmp);
7401 /* Make sure that the scalarizer data pointer is updated. */
7402 if (lss->data.info.data
7403 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7405 tmp = gfc_conv_descriptor_data_get (desc);
7406 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7409 /* Add the exit label. */
7410 tmp = build1_v (LABEL_EXPR, jump_label2);
7411 gfc_add_expr_to_block (&fblock, tmp);
7413 return gfc_finish_block (&fblock);
7417 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7418 Do likewise, recursively if necessary, with the allocatable components of
7422 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7428 stmtblock_t cleanup;
7431 bool sym_has_alloc_comp;
7433 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7434 || sym->ts.type == BT_CLASS)
7435 && sym->ts.u.derived->attr.alloc_comp;
7437 /* Make sure the frontend gets these right. */
7438 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7439 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7440 "allocatable attribute or derived type without allocatable "
7443 gfc_save_backend_locus (&loc);
7444 gfc_set_backend_locus (&sym->declared_at);
7445 gfc_init_block (&init);
7447 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7448 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7450 if (sym->ts.type == BT_CHARACTER
7451 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7453 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7454 gfc_trans_vla_type_sizes (sym, &init);
7457 /* Dummy, use associated and result variables don't need anything special. */
7458 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7460 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7461 gfc_restore_backend_locus (&loc);
7465 descriptor = sym->backend_decl;
7467 /* Although static, derived types with default initializers and
7468 allocatable components must not be nulled wholesale; instead they
7469 are treated component by component. */
7470 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7472 /* SAVEd variables are not freed on exit. */
7473 gfc_trans_static_array_pointer (sym);
7475 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7476 gfc_restore_backend_locus (&loc);
7480 /* Get the descriptor type. */
7481 type = TREE_TYPE (sym->backend_decl);
7483 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7486 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7488 if (sym->value == NULL
7489 || !gfc_has_default_initializer (sym->ts.u.derived))
7491 rank = sym->as ? sym->as->rank : 0;
7492 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7494 gfc_add_expr_to_block (&init, tmp);
7497 gfc_init_default_dt (sym, &init, false);
7500 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7502 /* If the backend_decl is not a descriptor, we must have a pointer
7504 descriptor = build_fold_indirect_ref_loc (input_location,
7506 type = TREE_TYPE (descriptor);
7509 /* NULLIFY the data pointer. */
7510 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7511 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7513 gfc_restore_backend_locus (&loc);
7514 gfc_init_block (&cleanup);
7516 /* Allocatable arrays need to be freed when they go out of scope.
7517 The allocatable components of pointers must not be touched. */
7518 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7519 && !sym->attr.pointer && !sym->attr.save)
7522 rank = sym->as ? sym->as->rank : 0;
7523 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7524 gfc_add_expr_to_block (&cleanup, tmp);
7527 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7528 && !sym->attr.save && !sym->attr.result)
7530 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7531 gfc_add_expr_to_block (&cleanup, tmp);
7534 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7535 gfc_finish_block (&cleanup));
7538 /************ Expression Walking Functions ******************/
7540 /* Walk a variable reference.
7542 Possible extension - multiple component subscripts.
7543 x(:,:) = foo%a(:)%b(:)
7545 forall (i=..., j=...)
7546 x(i,j) = foo%a(j)%b(i)
7548 This adds a fair amount of complexity because you need to deal with more
7549 than one ref. Maybe handle in a similar manner to vector subscripts.
7550 Maybe not worth the effort. */
7554 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7561 for (ref = expr->ref; ref; ref = ref->next)
7562 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7565 for (; ref; ref = ref->next)
7567 if (ref->type == REF_SUBSTRING)
7569 newss = gfc_get_ss ();
7570 newss->type = GFC_SS_SCALAR;
7571 newss->expr = ref->u.ss.start;
7575 newss = gfc_get_ss ();
7576 newss->type = GFC_SS_SCALAR;
7577 newss->expr = ref->u.ss.end;
7582 /* We're only interested in array sections from now on. */
7583 if (ref->type != REF_ARRAY)
7588 if (ar->as->rank == 0 && ref->next != NULL)
7590 /* Scalar coarray. */
7597 for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
7599 newss = gfc_get_ss ();
7600 newss->type = GFC_SS_SCALAR;
7601 newss->expr = ar->start[n];
7608 newss = gfc_get_ss ();
7609 newss->type = GFC_SS_SECTION;
7612 newss->data.info.dimen = ar->as->rank;
7613 newss->data.info.codimen = 0;
7614 newss->data.info.ref = ref;
7616 /* Make sure array is the same as array(:,:), this way
7617 we don't need to special case all the time. */
7618 ar->dimen = ar->as->rank;
7620 for (n = 0; n < ar->dimen; n++)
7622 newss->data.info.dim[n] = n;
7623 ar->dimen_type[n] = DIMEN_RANGE;
7625 gcc_assert (ar->start[n] == NULL);
7626 gcc_assert (ar->end[n] == NULL);
7627 gcc_assert (ar->stride[n] == NULL);
7629 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7631 newss->data.info.dim[n] = n;
7632 ar->dimen_type[n] = DIMEN_RANGE;
7634 gcc_assert (ar->start[n] == NULL);
7635 gcc_assert (ar->end[n] == NULL);
7641 newss = gfc_get_ss ();
7642 newss->type = GFC_SS_SECTION;
7645 newss->data.info.dimen = 0;
7646 newss->data.info.codimen = 0;
7647 newss->data.info.ref = ref;
7649 /* We add SS chains for all the subscripts in the section. */
7650 for (n = 0; n < ar->dimen + ar->codimen; n++)
7654 switch (ar->dimen_type[n])
7656 case DIMEN_THIS_IMAGE:
7659 /* Add SS for elemental (scalar) subscripts. */
7660 gcc_assert (ar->start[n]);
7661 indexss = gfc_get_ss ();
7662 indexss->type = GFC_SS_SCALAR;
7663 indexss->expr = ar->start[n];
7664 indexss->next = gfc_ss_terminator;
7665 indexss->loop_chain = gfc_ss_terminator;
7666 newss->data.info.subscript[n] = indexss;
7670 /* We don't add anything for sections, just remember this
7671 dimension for later. */
7672 newss->data.info.dim[newss->data.info.dimen
7673 + newss->data.info.codimen] = n;
7675 newss->data.info.dimen++;
7679 /* Create a GFC_SS_VECTOR index in which we can store
7680 the vector's descriptor. */
7681 indexss = gfc_get_ss ();
7682 indexss->type = GFC_SS_VECTOR;
7683 indexss->expr = ar->start[n];
7684 indexss->next = gfc_ss_terminator;
7685 indexss->loop_chain = gfc_ss_terminator;
7686 newss->data.info.subscript[n] = indexss;
7687 newss->data.info.dim[newss->data.info.dimen
7688 + newss->data.info.codimen] = n;
7690 newss->data.info.dimen++;
7694 /* We should know what sort of section it is by now. */
7698 /* We should have at least one non-elemental dimension. */
7699 gcc_assert (newss->data.info.dimen > 0);
7704 /* We should know what sort of section it is by now. */
7713 /* Walk an expression operator. If only one operand of a binary expression is
7714 scalar, we must also add the scalar term to the SS chain. */
7717 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7723 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7724 if (expr->value.op.op2 == NULL)
7727 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7729 /* All operands are scalar. Pass back and let the caller deal with it. */
7733 /* All operands require scalarization. */
7734 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7737 /* One of the operands needs scalarization, the other is scalar.
7738 Create a gfc_ss for the scalar expression. */
7739 newss = gfc_get_ss ();
7740 newss->type = GFC_SS_SCALAR;
7743 /* First operand is scalar. We build the chain in reverse order, so
7744 add the scalar SS after the second operand. */
7746 while (head && head->next != ss)
7748 /* Check we haven't somehow broken the chain. */
7752 newss->expr = expr->value.op.op1;
7754 else /* head2 == head */
7756 gcc_assert (head2 == head);
7757 /* Second operand is scalar. */
7758 newss->next = head2;
7760 newss->expr = expr->value.op.op2;
7767 /* Reverse a SS chain. */
7770 gfc_reverse_ss (gfc_ss * ss)
7775 gcc_assert (ss != NULL);
7777 head = gfc_ss_terminator;
7778 while (ss != gfc_ss_terminator)
7781 /* Check we didn't somehow break the chain. */
7782 gcc_assert (next != NULL);
7792 /* Walk the arguments of an elemental function. */
7795 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7803 head = gfc_ss_terminator;
7806 for (; arg; arg = arg->next)
7811 newss = gfc_walk_subexpr (head, arg->expr);
7814 /* Scalar argument. */
7815 newss = gfc_get_ss ();
7817 newss->expr = arg->expr;
7827 while (tail->next != gfc_ss_terminator)
7834 /* If all the arguments are scalar we don't need the argument SS. */
7835 gfc_free_ss_chain (head);
7840 /* Add it onto the existing chain. */
7846 /* Walk a function call. Scalar functions are passed back, and taken out of
7847 scalarization loops. For elemental functions we walk their arguments.
7848 The result of functions returning arrays is stored in a temporary outside
7849 the loop, so that the function is only called once. Hence we do not need
7850 to walk their arguments. */
7853 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7856 gfc_intrinsic_sym *isym;
7858 gfc_component *comp = NULL;
7861 isym = expr->value.function.isym;
7863 /* Handle intrinsic functions separately. */
7865 return gfc_walk_intrinsic_function (ss, expr, isym);
7867 sym = expr->value.function.esym;
7869 sym = expr->symtree->n.sym;
7871 /* A function that returns arrays. */
7872 gfc_is_proc_ptr_comp (expr, &comp);
7873 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7874 || (comp && comp->attr.dimension))
7876 newss = gfc_get_ss ();
7877 newss->type = GFC_SS_FUNCTION;
7880 newss->data.info.dimen = expr->rank;
7881 for (n = 0; n < newss->data.info.dimen; n++)
7882 newss->data.info.dim[n] = n;
7886 /* Walk the parameters of an elemental function. For now we always pass
7888 if (sym->attr.elemental)
7889 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7892 /* Scalar functions are OK as these are evaluated outside the scalarization
7893 loop. Pass back and let the caller deal with it. */
7898 /* An array temporary is constructed for array constructors. */
7901 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7906 newss = gfc_get_ss ();
7907 newss->type = GFC_SS_CONSTRUCTOR;
7910 newss->data.info.dimen = expr->rank;
7911 for (n = 0; n < expr->rank; n++)
7912 newss->data.info.dim[n] = n;
7918 /* Walk an expression. Add walked expressions to the head of the SS chain.
7919 A wholly scalar expression will not be added. */
7922 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7926 switch (expr->expr_type)
7929 head = gfc_walk_variable_expr (ss, expr);
7933 head = gfc_walk_op_expr (ss, expr);
7937 head = gfc_walk_function_expr (ss, expr);
7942 case EXPR_STRUCTURE:
7943 /* Pass back and let the caller deal with it. */
7947 head = gfc_walk_array_constructor (ss, expr);
7950 case EXPR_SUBSTRING:
7951 /* Pass back and let the caller deal with it. */
7955 internal_error ("bad expression type during walk (%d)",
7962 /* Entry point for expression walking.
7963 A return value equal to the passed chain means this is
7964 a scalar expression. It is up to the caller to take whatever action is
7965 necessary to translate these. */
7968 gfc_walk_expr (gfc_expr * expr)
7972 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7973 return gfc_reverse_ss (res);