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
133 #define STRIDE_SUBFIELD 0
134 #define LBOUND_SUBFIELD 1
135 #define UBOUND_SUBFIELD 2
137 /* This provides READ-ONLY access to the data field. The field itself
138 doesn't have the proper type. */
141 gfc_conv_descriptor_data_get (tree desc)
145 type = TREE_TYPE (desc);
146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
148 field = TYPE_FIELDS (type);
149 gcc_assert (DATA_FIELD == 0);
151 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
153 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
158 /* This provides WRITE access to the data field.
160 TUPLES_P is true if we are generating tuples.
162 This function gets called through the following macros:
163 gfc_conv_descriptor_data_set
164 gfc_conv_descriptor_data_set. */
167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
171 type = TREE_TYPE (desc);
172 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174 field = TYPE_FIELDS (type);
175 gcc_assert (DATA_FIELD == 0);
177 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
179 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
183 /* This provides address access to the data field. This should only be
184 used by array allocation, passing this on to the runtime. */
187 gfc_conv_descriptor_data_addr (tree desc)
191 type = TREE_TYPE (desc);
192 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
194 field = TYPE_FIELDS (type);
195 gcc_assert (DATA_FIELD == 0);
197 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
199 return gfc_build_addr_expr (NULL_TREE, t);
203 gfc_conv_descriptor_offset (tree desc)
208 type = TREE_TYPE (desc);
209 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
211 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
212 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
214 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
215 desc, field, NULL_TREE);
219 gfc_conv_descriptor_offset_get (tree desc)
221 return gfc_conv_descriptor_offset (desc);
225 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
228 tree t = gfc_conv_descriptor_offset (desc);
229 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
234 gfc_conv_descriptor_dtype (tree desc)
239 type = TREE_TYPE (desc);
240 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
242 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
243 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
245 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
246 desc, field, NULL_TREE);
250 gfc_conv_descriptor_dimension (tree desc, tree dim)
256 type = TREE_TYPE (desc);
257 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
259 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
260 gcc_assert (field != NULL_TREE
261 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
262 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
264 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
265 desc, field, NULL_TREE);
266 tmp = gfc_build_array_ref (tmp, dim, NULL);
271 gfc_conv_descriptor_stride (tree desc, tree dim)
276 tmp = gfc_conv_descriptor_dimension (desc, dim);
277 field = TYPE_FIELDS (TREE_TYPE (tmp));
278 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
279 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
281 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
282 tmp, field, NULL_TREE);
287 gfc_conv_descriptor_stride_get (tree desc, tree dim)
289 tree type = TREE_TYPE (desc);
290 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
291 if (integer_zerop (dim)
292 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
293 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
294 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
295 return gfc_index_one_node;
297 return gfc_conv_descriptor_stride (desc, dim);
301 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
302 tree dim, tree value)
304 tree t = gfc_conv_descriptor_stride (desc, dim);
305 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
309 gfc_conv_descriptor_lbound (tree desc, tree dim)
314 tmp = gfc_conv_descriptor_dimension (desc, dim);
315 field = TYPE_FIELDS (TREE_TYPE (tmp));
316 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
317 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
319 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
320 tmp, field, NULL_TREE);
325 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
327 return gfc_conv_descriptor_lbound (desc, dim);
331 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
332 tree dim, tree value)
334 tree t = gfc_conv_descriptor_lbound (desc, dim);
335 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
339 gfc_conv_descriptor_ubound (tree desc, tree dim)
344 tmp = gfc_conv_descriptor_dimension (desc, dim);
345 field = TYPE_FIELDS (TREE_TYPE (tmp));
346 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
347 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
349 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
350 tmp, field, NULL_TREE);
355 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
357 return gfc_conv_descriptor_ubound (desc, dim);
361 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
362 tree dim, tree value)
364 tree t = gfc_conv_descriptor_ubound (desc, dim);
365 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
368 /* Build a null array descriptor constructor. */
371 gfc_build_null_descriptor (tree type)
376 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
377 gcc_assert (DATA_FIELD == 0);
378 field = TYPE_FIELDS (type);
380 /* Set a NULL data pointer. */
381 tmp = build_constructor_single (type, field, null_pointer_node);
382 TREE_CONSTANT (tmp) = 1;
383 /* All other fields are ignored. */
389 /* Modify a descriptor such that the lbound of a given dimension is the value
390 specified. This also updates ubound and offset accordingly. */
393 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
394 int dim, tree new_lbound)
396 tree offs, ubound, lbound, stride;
397 tree diff, offs_diff;
399 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
401 offs = gfc_conv_descriptor_offset_get (desc);
402 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
403 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
404 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
406 /* Get difference (new - old) by which to shift stuff. */
407 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
410 /* Shift ubound and offset accordingly. This has to be done before
411 updating the lbound, as they depend on the lbound expression! */
412 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
414 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
415 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
417 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
419 gfc_conv_descriptor_offset_set (block, desc, offs);
421 /* Finally set lbound to value we want. */
422 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
426 /* Cleanup those #defines. */
431 #undef DIMENSION_FIELD
432 #undef STRIDE_SUBFIELD
433 #undef LBOUND_SUBFIELD
434 #undef UBOUND_SUBFIELD
437 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
438 flags & 1 = Main loop body.
439 flags & 2 = temp copy loop. */
442 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
444 for (; ss != gfc_ss_terminator; ss = ss->next)
445 ss->useflags = flags;
448 static void gfc_free_ss (gfc_ss *);
451 /* Free a gfc_ss chain. */
454 gfc_free_ss_chain (gfc_ss * ss)
458 while (ss != gfc_ss_terminator)
460 gcc_assert (ss != NULL);
471 gfc_free_ss (gfc_ss * ss)
478 for (n = 0; n < ss->data.info.dimen; n++)
480 if (ss->data.info.subscript[ss->data.info.dim[n]])
481 gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]);
493 /* Free all the SS associated with a loop. */
496 gfc_cleanup_loop (gfc_loopinfo * loop)
502 while (ss != gfc_ss_terminator)
504 gcc_assert (ss != NULL);
505 next = ss->loop_chain;
512 /* Associate a SS chain with a loop. */
515 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
519 if (head == gfc_ss_terminator)
523 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
525 if (ss->next == gfc_ss_terminator)
526 ss->loop_chain = loop->ss;
528 ss->loop_chain = ss->next;
530 gcc_assert (ss == gfc_ss_terminator);
535 /* Generate an initializer for a static pointer or allocatable array. */
538 gfc_trans_static_array_pointer (gfc_symbol * sym)
542 gcc_assert (TREE_STATIC (sym->backend_decl));
543 /* Just zero the data member. */
544 type = TREE_TYPE (sym->backend_decl);
545 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
549 /* If the bounds of SE's loop have not yet been set, see if they can be
550 determined from array spec AS, which is the array spec of a called
551 function. MAPPING maps the callee's dummy arguments to the values
552 that the caller is passing. Add any initialization and finalization
556 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
557 gfc_se * se, gfc_array_spec * as)
565 if (as && as->type == AS_EXPLICIT)
566 for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
568 dim = se->ss->data.info.dim[n];
569 gcc_assert (dim < as->rank);
570 gcc_assert (se->loop->dimen == as->rank);
571 if (se->loop->to[n] == NULL_TREE)
573 /* Evaluate the lower bound. */
574 gfc_init_se (&tmpse, NULL);
575 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
576 gfc_add_block_to_block (&se->pre, &tmpse.pre);
577 gfc_add_block_to_block (&se->post, &tmpse.post);
578 lower = fold_convert (gfc_array_index_type, tmpse.expr);
580 if (se->loop->codimen == 0
581 || n < se->loop->dimen + se->loop->codimen - 1)
583 /* ...and the upper bound. */
584 gfc_init_se (&tmpse, NULL);
585 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
586 gfc_add_block_to_block (&se->pre, &tmpse.pre);
587 gfc_add_block_to_block (&se->post, &tmpse.post);
588 upper = fold_convert (gfc_array_index_type, tmpse.expr);
590 /* Set the upper bound of the loop to UPPER - LOWER. */
591 tmp = fold_build2_loc (input_location, MINUS_EXPR,
592 gfc_array_index_type, upper, lower);
593 tmp = gfc_evaluate_now (tmp, &se->pre);
594 se->loop->to[n] = tmp;
601 /* Generate code to allocate an array temporary, or create a variable to
602 hold the data. If size is NULL, zero the descriptor so that the
603 callee will allocate the array. If DEALLOC is true, also generate code to
604 free the array afterwards.
606 If INITIAL is not NULL, it is packed using internal_pack and the result used
607 as data instead of allocating a fresh, unitialized area of memory.
609 Initialization code is added to PRE and finalization code to POST.
610 DYNAMIC is true if the caller may want to extend the array later
611 using realloc. This prevents us from putting the array on the stack. */
614 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
615 gfc_ss_info * info, tree size, tree nelem,
616 tree initial, bool dynamic, bool dealloc)
622 desc = info->descriptor;
623 info->offset = gfc_index_zero_node;
624 if (size == NULL_TREE || integer_zerop (size))
626 /* A callee allocated array. */
627 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
632 /* Allocate the temporary. */
633 onstack = !dynamic && initial == NULL_TREE
634 && (gfc_option.flag_stack_arrays
635 || gfc_can_put_var_on_stack (size));
639 /* Make a temporary variable to hold the data. */
640 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
641 nelem, gfc_index_one_node);
642 tmp = gfc_evaluate_now (tmp, pre);
643 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
645 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
647 tmp = gfc_create_var (tmp, "A");
648 /* If we're here only because of -fstack-arrays we have to
649 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
650 if (!gfc_can_put_var_on_stack (size))
651 gfc_add_expr_to_block (pre,
652 fold_build1_loc (input_location,
653 DECL_EXPR, TREE_TYPE (tmp),
655 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
656 gfc_conv_descriptor_data_set (pre, desc, tmp);
660 /* Allocate memory to hold the data or call internal_pack. */
661 if (initial == NULL_TREE)
663 tmp = gfc_call_malloc (pre, NULL, size);
664 tmp = gfc_evaluate_now (tmp, pre);
671 stmtblock_t do_copying;
673 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
674 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
675 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
676 tmp = gfc_get_element_type (tmp);
677 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
678 packed = gfc_create_var (build_pointer_type (tmp), "data");
680 tmp = build_call_expr_loc (input_location,
681 gfor_fndecl_in_pack, 1, initial);
682 tmp = fold_convert (TREE_TYPE (packed), tmp);
683 gfc_add_modify (pre, packed, tmp);
685 tmp = build_fold_indirect_ref_loc (input_location,
687 source_data = gfc_conv_descriptor_data_get (tmp);
689 /* internal_pack may return source->data without any allocation
690 or copying if it is already packed. If that's the case, we
691 need to allocate and copy manually. */
693 gfc_start_block (&do_copying);
694 tmp = gfc_call_malloc (&do_copying, NULL, size);
695 tmp = fold_convert (TREE_TYPE (packed), tmp);
696 gfc_add_modify (&do_copying, packed, tmp);
697 tmp = gfc_build_memcpy_call (packed, source_data, size);
698 gfc_add_expr_to_block (&do_copying, tmp);
700 was_packed = fold_build2_loc (input_location, EQ_EXPR,
701 boolean_type_node, packed,
703 tmp = gfc_finish_block (&do_copying);
704 tmp = build3_v (COND_EXPR, was_packed, tmp,
705 build_empty_stmt (input_location));
706 gfc_add_expr_to_block (pre, tmp);
708 tmp = fold_convert (pvoid_type_node, packed);
711 gfc_conv_descriptor_data_set (pre, desc, tmp);
714 info->data = gfc_conv_descriptor_data_get (desc);
716 /* The offset is zero because we create temporaries with a zero
718 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
720 if (dealloc && !onstack)
722 /* Free the temporary. */
723 tmp = gfc_conv_descriptor_data_get (desc);
724 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
725 gfc_add_expr_to_block (post, tmp);
730 /* Get the array reference dimension corresponding to the given loop dimension.
731 It is different from the true array dimension given by the dim array in
732 the case of a partial array reference
733 It is different from the loop dimension in the case of a transposed array.
737 get_array_ref_dim (gfc_ss_info *info, int loop_dim)
739 int n, array_dim, array_ref_dim;
742 array_dim = info->dim[loop_dim];
744 for (n = 0; n < info->dimen; n++)
745 if (n != loop_dim && info->dim[n] < array_dim)
748 return array_ref_dim;
752 /* Generate code to create and initialize the descriptor for a temporary
753 array. This is used for both temporaries needed by the scalarizer, and
754 functions returning arrays. Adjusts the loop variables to be
755 zero-based, and calculates the loop bounds for callee allocated arrays.
756 Allocate the array unless it's callee allocated (we have a callee
757 allocated array if 'callee_alloc' is true, or if loop->to[n] is
758 NULL_TREE for any n). Also fills in the descriptor, data and offset
759 fields of info if known. Returns the size of the array, or NULL for a
760 callee allocated array.
762 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
763 gfc_trans_allocate_array_storage.
767 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
768 gfc_loopinfo * loop, gfc_ss_info * info,
769 tree eltype, tree initial, bool dynamic,
770 bool dealloc, bool callee_alloc, locus * where)
772 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
782 memset (from, 0, sizeof (from));
783 memset (to, 0, sizeof (to));
785 gcc_assert (info->dimen > 0);
786 gcc_assert (loop->dimen == info->dimen);
788 if (gfc_option.warn_array_temp && where)
789 gfc_warning ("Creating array temporary at %L", where);
791 /* Set the lower bound to zero. */
792 for (n = 0; n < loop->dimen; n++)
796 /* Callee allocated arrays may not have a known bound yet. */
798 loop->to[n] = gfc_evaluate_now (
799 fold_build2_loc (input_location, MINUS_EXPR,
800 gfc_array_index_type,
801 loop->to[n], loop->from[n]),
803 loop->from[n] = gfc_index_zero_node;
805 /* We are constructing the temporary's descriptor based on the loop
806 dimensions. As the dimensions may be accessed in arbitrary order
807 (think of transpose) the size taken from the n'th loop may not map
808 to the n'th dimension of the array. We need to reconstruct loop infos
809 in the right order before using it to set the descriptor
811 tmp_dim = get_array_ref_dim (info, n);
812 from[tmp_dim] = loop->from[n];
813 to[tmp_dim] = loop->to[n];
815 info->delta[dim] = gfc_index_zero_node;
816 info->start[dim] = gfc_index_zero_node;
817 info->end[dim] = gfc_index_zero_node;
818 info->stride[dim] = gfc_index_one_node;
821 /* Initialize the descriptor. */
823 gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1,
824 GFC_ARRAY_UNKNOWN, true);
825 desc = gfc_create_var (type, "atmp");
826 GFC_DECL_PACKED_ARRAY (desc) = 1;
828 info->descriptor = desc;
829 size = gfc_index_one_node;
831 /* Fill in the array dtype. */
832 tmp = gfc_conv_descriptor_dtype (desc);
833 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
836 Fill in the bounds and stride. This is a packed array, so:
839 for (n = 0; n < rank; n++)
842 delta = ubound[n] + 1 - lbound[n];
845 size = size * sizeof(element);
850 /* If there is at least one null loop->to[n], it is a callee allocated
852 for (n = 0; n < loop->dimen; n++)
853 if (loop->to[n] == NULL_TREE)
859 for (n = 0; n < loop->dimen; n++)
863 if (size == NULL_TREE)
865 /* For a callee allocated array express the loop bounds in terms
866 of the descriptor fields. */
867 tmp = fold_build2_loc (input_location,
868 MINUS_EXPR, gfc_array_index_type,
869 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
870 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
875 /* Store the stride and bound components in the descriptor. */
876 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
878 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
879 gfc_index_zero_node);
881 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
884 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
885 to[n], gfc_index_one_node);
887 /* Check whether the size for this dimension is negative. */
888 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
889 gfc_index_zero_node);
890 cond = gfc_evaluate_now (cond, pre);
895 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
896 boolean_type_node, or_expr, cond);
898 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
900 size = gfc_evaluate_now (size, pre);
902 for (n = info->dimen; n < info->dimen + info->codimen; n++)
904 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
905 gfc_index_zero_node);
906 if (n < info->dimen + info->codimen - 1)
907 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
910 /* Get the size of the array. */
912 if (size && !callee_alloc)
914 /* If or_expr is true, then the extent in at least one
915 dimension is zero and the size is set to zero. */
916 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
917 or_expr, gfc_index_zero_node, size);
920 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
922 fold_convert (gfc_array_index_type,
923 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
931 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
934 if (info->dimen > loop->temp_dim)
935 loop->temp_dim = info->dimen;
941 /* Return the number of iterations in a loop that starts at START,
942 ends at END, and has step STEP. */
945 gfc_get_iteration_count (tree start, tree end, tree step)
950 type = TREE_TYPE (step);
951 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
952 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
953 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
954 build_int_cst (type, 1));
955 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
956 build_int_cst (type, 0));
957 return fold_convert (gfc_array_index_type, tmp);
961 /* Extend the data in array DESC by EXTRA elements. */
964 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
971 if (integer_zerop (extra))
974 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
976 /* Add EXTRA to the upper bound. */
977 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
979 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
981 /* Get the value of the current data pointer. */
982 arg0 = gfc_conv_descriptor_data_get (desc);
984 /* Calculate the new array size. */
985 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
986 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
987 ubound, gfc_index_one_node);
988 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
989 fold_convert (size_type_node, tmp),
990 fold_convert (size_type_node, size));
992 /* Call the realloc() function. */
993 tmp = gfc_call_realloc (pblock, arg0, arg1);
994 gfc_conv_descriptor_data_set (pblock, desc, tmp);
998 /* Return true if the bounds of iterator I can only be determined
1002 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1004 return (i->start->expr_type != EXPR_CONSTANT
1005 || i->end->expr_type != EXPR_CONSTANT
1006 || i->step->expr_type != EXPR_CONSTANT);
1010 /* Split the size of constructor element EXPR into the sum of two terms,
1011 one of which can be determined at compile time and one of which must
1012 be calculated at run time. Set *SIZE to the former and return true
1013 if the latter might be nonzero. */
1016 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1018 if (expr->expr_type == EXPR_ARRAY)
1019 return gfc_get_array_constructor_size (size, expr->value.constructor);
1020 else if (expr->rank > 0)
1022 /* Calculate everything at run time. */
1023 mpz_set_ui (*size, 0);
1028 /* A single element. */
1029 mpz_set_ui (*size, 1);
1035 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1036 of array constructor C. */
1039 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1047 mpz_set_ui (*size, 0);
1052 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1055 if (i && gfc_iterator_has_dynamic_bounds (i))
1059 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1062 /* Multiply the static part of the element size by the
1063 number of iterations. */
1064 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1065 mpz_fdiv_q (val, val, i->step->value.integer);
1066 mpz_add_ui (val, val, 1);
1067 if (mpz_sgn (val) > 0)
1068 mpz_mul (len, len, val);
1070 mpz_set_ui (len, 0);
1072 mpz_add (*size, *size, len);
1081 /* Make sure offset is a variable. */
1084 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1087 /* We should have already created the offset variable. We cannot
1088 create it here because we may be in an inner scope. */
1089 gcc_assert (*offsetvar != NULL_TREE);
1090 gfc_add_modify (pblock, *offsetvar, *poffset);
1091 *poffset = *offsetvar;
1092 TREE_USED (*offsetvar) = 1;
1096 /* Variables needed for bounds-checking. */
1097 static bool first_len;
1098 static tree first_len_val;
1099 static bool typespec_chararray_ctor;
1102 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1103 tree offset, gfc_se * se, gfc_expr * expr)
1107 gfc_conv_expr (se, expr);
1109 /* Store the value. */
1110 tmp = build_fold_indirect_ref_loc (input_location,
1111 gfc_conv_descriptor_data_get (desc));
1112 tmp = gfc_build_array_ref (tmp, offset, NULL);
1114 if (expr->ts.type == BT_CHARACTER)
1116 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1119 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1120 esize = fold_convert (gfc_charlen_type_node, esize);
1121 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1122 gfc_charlen_type_node, esize,
1123 build_int_cst (gfc_charlen_type_node,
1124 gfc_character_kinds[i].bit_size / 8));
1126 gfc_conv_string_parameter (se);
1127 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1129 /* The temporary is an array of pointers. */
1130 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1131 gfc_add_modify (&se->pre, tmp, se->expr);
1135 /* The temporary is an array of string values. */
1136 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1137 /* We know the temporary and the value will be the same length,
1138 so can use memcpy. */
1139 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1140 se->string_length, se->expr, expr->ts.kind);
1142 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1146 gfc_add_modify (&se->pre, first_len_val,
1152 /* Verify that all constructor elements are of the same
1154 tree cond = fold_build2_loc (input_location, NE_EXPR,
1155 boolean_type_node, first_len_val,
1157 gfc_trans_runtime_check
1158 (true, false, cond, &se->pre, &expr->where,
1159 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1160 fold_convert (long_integer_type_node, first_len_val),
1161 fold_convert (long_integer_type_node, se->string_length));
1167 /* TODO: Should the frontend already have done this conversion? */
1168 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1169 gfc_add_modify (&se->pre, tmp, se->expr);
1172 gfc_add_block_to_block (pblock, &se->pre);
1173 gfc_add_block_to_block (pblock, &se->post);
1177 /* Add the contents of an array to the constructor. DYNAMIC is as for
1178 gfc_trans_array_constructor_value. */
1181 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1182 tree type ATTRIBUTE_UNUSED,
1183 tree desc, gfc_expr * expr,
1184 tree * poffset, tree * offsetvar,
1195 /* We need this to be a variable so we can increment it. */
1196 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1198 gfc_init_se (&se, NULL);
1200 /* Walk the array expression. */
1201 ss = gfc_walk_expr (expr);
1202 gcc_assert (ss != gfc_ss_terminator);
1204 /* Initialize the scalarizer. */
1205 gfc_init_loopinfo (&loop);
1206 gfc_add_ss_to_loop (&loop, ss);
1208 /* Initialize the loop. */
1209 gfc_conv_ss_startstride (&loop);
1210 gfc_conv_loop_setup (&loop, &expr->where);
1212 /* Make sure the constructed array has room for the new data. */
1215 /* Set SIZE to the total number of elements in the subarray. */
1216 size = gfc_index_one_node;
1217 for (n = 0; n < loop.dimen; n++)
1219 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1220 gfc_index_one_node);
1221 size = fold_build2_loc (input_location, MULT_EXPR,
1222 gfc_array_index_type, size, tmp);
1225 /* Grow the constructed array by SIZE elements. */
1226 gfc_grow_array (&loop.pre, desc, size);
1229 /* Make the loop body. */
1230 gfc_mark_ss_chain_used (ss, 1);
1231 gfc_start_scalarized_body (&loop, &body);
1232 gfc_copy_loopinfo_to_se (&se, &loop);
1235 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1236 gcc_assert (se.ss == gfc_ss_terminator);
1238 /* Increment the offset. */
1239 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1240 *poffset, gfc_index_one_node);
1241 gfc_add_modify (&body, *poffset, tmp);
1243 /* Finish the loop. */
1244 gfc_trans_scalarizing_loops (&loop, &body);
1245 gfc_add_block_to_block (&loop.pre, &loop.post);
1246 tmp = gfc_finish_block (&loop.pre);
1247 gfc_add_expr_to_block (pblock, tmp);
1249 gfc_cleanup_loop (&loop);
1253 /* Assign the values to the elements of an array constructor. DYNAMIC
1254 is true if descriptor DESC only contains enough data for the static
1255 size calculated by gfc_get_array_constructor_size. When true, memory
1256 for the dynamic parts must be allocated using realloc. */
1259 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1260 tree desc, gfc_constructor_base base,
1261 tree * poffset, tree * offsetvar,
1270 tree shadow_loopvar = NULL_TREE;
1271 gfc_saved_var saved_loopvar;
1274 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1276 /* If this is an iterator or an array, the offset must be a variable. */
1277 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1278 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1280 /* Shadowing the iterator avoids changing its value and saves us from
1281 keeping track of it. Further, it makes sure that there's always a
1282 backend-decl for the symbol, even if there wasn't one before,
1283 e.g. in the case of an iterator that appears in a specification
1284 expression in an interface mapping. */
1287 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1288 tree type = gfc_typenode_for_spec (&sym->ts);
1290 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1291 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1294 gfc_start_block (&body);
1296 if (c->expr->expr_type == EXPR_ARRAY)
1298 /* Array constructors can be nested. */
1299 gfc_trans_array_constructor_value (&body, type, desc,
1300 c->expr->value.constructor,
1301 poffset, offsetvar, dynamic);
1303 else if (c->expr->rank > 0)
1305 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1306 poffset, offsetvar, dynamic);
1310 /* This code really upsets the gimplifier so don't bother for now. */
1317 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1319 p = gfc_constructor_next (p);
1324 /* Scalar values. */
1325 gfc_init_se (&se, NULL);
1326 gfc_trans_array_ctor_element (&body, desc, *poffset,
1329 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1330 gfc_array_index_type,
1331 *poffset, gfc_index_one_node);
1335 /* Collect multiple scalar constants into a constructor. */
1336 VEC(constructor_elt,gc) *v = NULL;
1340 HOST_WIDE_INT idx = 0;
1343 /* Count the number of consecutive scalar constants. */
1344 while (p && !(p->iterator
1345 || p->expr->expr_type != EXPR_CONSTANT))
1347 gfc_init_se (&se, NULL);
1348 gfc_conv_constant (&se, p->expr);
1350 if (c->expr->ts.type != BT_CHARACTER)
1351 se.expr = fold_convert (type, se.expr);
1352 /* For constant character array constructors we build
1353 an array of pointers. */
1354 else if (POINTER_TYPE_P (type))
1355 se.expr = gfc_build_addr_expr
1356 (gfc_get_pchar_type (p->expr->ts.kind),
1359 CONSTRUCTOR_APPEND_ELT (v,
1360 build_int_cst (gfc_array_index_type,
1364 p = gfc_constructor_next (p);
1367 bound = size_int (n - 1);
1368 /* Create an array type to hold them. */
1369 tmptype = build_range_type (gfc_array_index_type,
1370 gfc_index_zero_node, bound);
1371 tmptype = build_array_type (type, tmptype);
1373 init = build_constructor (tmptype, v);
1374 TREE_CONSTANT (init) = 1;
1375 TREE_STATIC (init) = 1;
1376 /* Create a static variable to hold the data. */
1377 tmp = gfc_create_var (tmptype, "data");
1378 TREE_STATIC (tmp) = 1;
1379 TREE_CONSTANT (tmp) = 1;
1380 TREE_READONLY (tmp) = 1;
1381 DECL_INITIAL (tmp) = init;
1384 /* Use BUILTIN_MEMCPY to assign the values. */
1385 tmp = gfc_conv_descriptor_data_get (desc);
1386 tmp = build_fold_indirect_ref_loc (input_location,
1388 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1389 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1390 init = gfc_build_addr_expr (NULL_TREE, init);
1392 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1393 bound = build_int_cst (size_type_node, n * size);
1394 tmp = build_call_expr_loc (input_location,
1395 built_in_decls[BUILT_IN_MEMCPY], 3,
1397 gfc_add_expr_to_block (&body, tmp);
1399 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1400 gfc_array_index_type, *poffset,
1401 build_int_cst (gfc_array_index_type, n));
1403 if (!INTEGER_CST_P (*poffset))
1405 gfc_add_modify (&body, *offsetvar, *poffset);
1406 *poffset = *offsetvar;
1410 /* The frontend should already have done any expansions
1414 /* Pass the code as is. */
1415 tmp = gfc_finish_block (&body);
1416 gfc_add_expr_to_block (pblock, tmp);
1420 /* Build the implied do-loop. */
1421 stmtblock_t implied_do_block;
1429 loopbody = gfc_finish_block (&body);
1431 /* Create a new block that holds the implied-do loop. A temporary
1432 loop-variable is used. */
1433 gfc_start_block(&implied_do_block);
1435 /* Initialize the loop. */
1436 gfc_init_se (&se, NULL);
1437 gfc_conv_expr_val (&se, c->iterator->start);
1438 gfc_add_block_to_block (&implied_do_block, &se.pre);
1439 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1441 gfc_init_se (&se, NULL);
1442 gfc_conv_expr_val (&se, c->iterator->end);
1443 gfc_add_block_to_block (&implied_do_block, &se.pre);
1444 end = gfc_evaluate_now (se.expr, &implied_do_block);
1446 gfc_init_se (&se, NULL);
1447 gfc_conv_expr_val (&se, c->iterator->step);
1448 gfc_add_block_to_block (&implied_do_block, &se.pre);
1449 step = gfc_evaluate_now (se.expr, &implied_do_block);
1451 /* If this array expands dynamically, and the number of iterations
1452 is not constant, we won't have allocated space for the static
1453 part of C->EXPR's size. Do that now. */
1454 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1456 /* Get the number of iterations. */
1457 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1459 /* Get the static part of C->EXPR's size. */
1460 gfc_get_array_constructor_element_size (&size, c->expr);
1461 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1463 /* Grow the array by TMP * TMP2 elements. */
1464 tmp = fold_build2_loc (input_location, MULT_EXPR,
1465 gfc_array_index_type, tmp, tmp2);
1466 gfc_grow_array (&implied_do_block, desc, tmp);
1469 /* Generate the loop body. */
1470 exit_label = gfc_build_label_decl (NULL_TREE);
1471 gfc_start_block (&body);
1473 /* Generate the exit condition. Depending on the sign of
1474 the step variable we have to generate the correct
1476 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1477 step, build_int_cst (TREE_TYPE (step), 0));
1478 cond = fold_build3_loc (input_location, COND_EXPR,
1479 boolean_type_node, tmp,
1480 fold_build2_loc (input_location, GT_EXPR,
1481 boolean_type_node, shadow_loopvar, end),
1482 fold_build2_loc (input_location, LT_EXPR,
1483 boolean_type_node, shadow_loopvar, end));
1484 tmp = build1_v (GOTO_EXPR, exit_label);
1485 TREE_USED (exit_label) = 1;
1486 tmp = build3_v (COND_EXPR, cond, tmp,
1487 build_empty_stmt (input_location));
1488 gfc_add_expr_to_block (&body, tmp);
1490 /* The main loop body. */
1491 gfc_add_expr_to_block (&body, loopbody);
1493 /* Increase loop variable by step. */
1494 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1495 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1497 gfc_add_modify (&body, shadow_loopvar, tmp);
1499 /* Finish the loop. */
1500 tmp = gfc_finish_block (&body);
1501 tmp = build1_v (LOOP_EXPR, tmp);
1502 gfc_add_expr_to_block (&implied_do_block, tmp);
1504 /* Add the exit label. */
1505 tmp = build1_v (LABEL_EXPR, exit_label);
1506 gfc_add_expr_to_block (&implied_do_block, tmp);
1508 /* Finishe the implied-do loop. */
1509 tmp = gfc_finish_block(&implied_do_block);
1510 gfc_add_expr_to_block(pblock, tmp);
1512 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1519 /* A catch-all to obtain the string length for anything that is not a
1520 a substring of non-constant length, a constant, array or variable. */
1523 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1528 /* Don't bother if we already know the length is a constant. */
1529 if (*len && INTEGER_CST_P (*len))
1532 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1533 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1536 gfc_conv_const_charlen (e->ts.u.cl);
1537 *len = e->ts.u.cl->backend_decl;
1541 /* Otherwise, be brutal even if inefficient. */
1542 ss = gfc_walk_expr (e);
1543 gfc_init_se (&se, NULL);
1545 /* No function call, in case of side effects. */
1546 se.no_function_call = 1;
1547 if (ss == gfc_ss_terminator)
1548 gfc_conv_expr (&se, e);
1550 gfc_conv_expr_descriptor (&se, e, ss);
1552 /* Fix the value. */
1553 *len = gfc_evaluate_now (se.string_length, &se.pre);
1555 gfc_add_block_to_block (block, &se.pre);
1556 gfc_add_block_to_block (block, &se.post);
1558 e->ts.u.cl->backend_decl = *len;
1563 /* Figure out the string length of a variable reference expression.
1564 Used by get_array_ctor_strlen. */
1567 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1573 /* Don't bother if we already know the length is a constant. */
1574 if (*len && INTEGER_CST_P (*len))
1577 ts = &expr->symtree->n.sym->ts;
1578 for (ref = expr->ref; ref; ref = ref->next)
1583 /* Array references don't change the string length. */
1587 /* Use the length of the component. */
1588 ts = &ref->u.c.component->ts;
1592 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1593 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1595 /* Note that this might evaluate expr. */
1596 get_array_ctor_all_strlen (block, expr, len);
1599 mpz_init_set_ui (char_len, 1);
1600 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1601 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1602 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1603 *len = convert (gfc_charlen_type_node, *len);
1604 mpz_clear (char_len);
1612 *len = ts->u.cl->backend_decl;
1616 /* Figure out the string length of a character array constructor.
1617 If len is NULL, don't calculate the length; this happens for recursive calls
1618 when a sub-array-constructor is an element but not at the first position,
1619 so when we're not interested in the length.
1620 Returns TRUE if all elements are character constants. */
1623 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1630 if (gfc_constructor_first (base) == NULL)
1633 *len = build_int_cstu (gfc_charlen_type_node, 0);
1637 /* Loop over all constructor elements to find out is_const, but in len we
1638 want to store the length of the first, not the last, element. We can
1639 of course exit the loop as soon as is_const is found to be false. */
1640 for (c = gfc_constructor_first (base);
1641 c && is_const; c = gfc_constructor_next (c))
1643 switch (c->expr->expr_type)
1646 if (len && !(*len && INTEGER_CST_P (*len)))
1647 *len = build_int_cstu (gfc_charlen_type_node,
1648 c->expr->value.character.length);
1652 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1659 get_array_ctor_var_strlen (block, c->expr, len);
1665 get_array_ctor_all_strlen (block, c->expr, len);
1669 /* After the first iteration, we don't want the length modified. */
1676 /* Check whether the array constructor C consists entirely of constant
1677 elements, and if so returns the number of those elements, otherwise
1678 return zero. Note, an empty or NULL array constructor returns zero. */
1680 unsigned HOST_WIDE_INT
1681 gfc_constant_array_constructor_p (gfc_constructor_base base)
1683 unsigned HOST_WIDE_INT nelem = 0;
1685 gfc_constructor *c = gfc_constructor_first (base);
1689 || c->expr->rank > 0
1690 || c->expr->expr_type != EXPR_CONSTANT)
1692 c = gfc_constructor_next (c);
1699 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1700 and the tree type of it's elements, TYPE, return a static constant
1701 variable that is compile-time initialized. */
1704 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1706 tree tmptype, init, tmp;
1707 HOST_WIDE_INT nelem;
1712 VEC(constructor_elt,gc) *v = NULL;
1714 /* First traverse the constructor list, converting the constants
1715 to tree to build an initializer. */
1717 c = gfc_constructor_first (expr->value.constructor);
1720 gfc_init_se (&se, NULL);
1721 gfc_conv_constant (&se, c->expr);
1722 if (c->expr->ts.type != BT_CHARACTER)
1723 se.expr = fold_convert (type, se.expr);
1724 else if (POINTER_TYPE_P (type))
1725 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1727 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1729 c = gfc_constructor_next (c);
1733 /* Next determine the tree type for the array. We use the gfortran
1734 front-end's gfc_get_nodesc_array_type in order to create a suitable
1735 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1737 memset (&as, 0, sizeof (gfc_array_spec));
1739 as.rank = expr->rank;
1740 as.type = AS_EXPLICIT;
1743 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1744 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1748 for (i = 0; i < expr->rank; i++)
1750 int tmp = (int) mpz_get_si (expr->shape[i]);
1751 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1752 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1756 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1758 /* as is not needed anymore. */
1759 for (i = 0; i < as.rank + as.corank; i++)
1761 gfc_free_expr (as.lower[i]);
1762 gfc_free_expr (as.upper[i]);
1765 init = build_constructor (tmptype, v);
1767 TREE_CONSTANT (init) = 1;
1768 TREE_STATIC (init) = 1;
1770 tmp = gfc_create_var (tmptype, "A");
1771 TREE_STATIC (tmp) = 1;
1772 TREE_CONSTANT (tmp) = 1;
1773 TREE_READONLY (tmp) = 1;
1774 DECL_INITIAL (tmp) = init;
1780 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1781 This mostly initializes the scalarizer state info structure with the
1782 appropriate values to directly use the array created by the function
1783 gfc_build_constant_array_constructor. */
1786 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1787 gfc_ss * ss, tree type)
1793 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1795 info = &ss->data.info;
1797 info->descriptor = tmp;
1798 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1799 info->offset = gfc_index_zero_node;
1801 for (i = 0; i < info->dimen + info->codimen; i++)
1803 info->delta[i] = gfc_index_zero_node;
1804 info->start[i] = gfc_index_zero_node;
1805 info->end[i] = gfc_index_zero_node;
1806 info->stride[i] = gfc_index_one_node;
1810 if (info->dimen > loop->temp_dim)
1811 loop->temp_dim = info->dimen;
1814 /* Helper routine of gfc_trans_array_constructor to determine if the
1815 bounds of the loop specified by LOOP are constant and simple enough
1816 to use with gfc_trans_constant_array_constructor. Returns the
1817 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1820 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1822 tree size = gfc_index_one_node;
1826 for (i = 0; i < loop->dimen; i++)
1828 /* If the bounds aren't constant, return NULL_TREE. */
1829 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1831 if (!integer_zerop (loop->from[i]))
1833 /* Only allow nonzero "from" in one-dimensional arrays. */
1834 if (loop->dimen != 1)
1836 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1837 gfc_array_index_type,
1838 loop->to[i], loop->from[i]);
1842 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1843 tmp, gfc_index_one_node);
1844 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1852 /* Array constructors are handled by constructing a temporary, then using that
1853 within the scalarization loop. This is not optimal, but seems by far the
1857 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1859 gfc_constructor_base c;
1866 bool old_first_len, old_typespec_chararray_ctor;
1867 tree old_first_len_val;
1869 /* Save the old values for nested checking. */
1870 old_first_len = first_len;
1871 old_first_len_val = first_len_val;
1872 old_typespec_chararray_ctor = typespec_chararray_ctor;
1874 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1875 typespec was given for the array constructor. */
1876 typespec_chararray_ctor = (ss->expr->ts.u.cl
1877 && ss->expr->ts.u.cl->length_from_typespec);
1879 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1880 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1882 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1886 ss->data.info.dimen = loop->dimen;
1888 c = ss->expr->value.constructor;
1889 if (ss->expr->ts.type == BT_CHARACTER)
1893 /* get_array_ctor_strlen walks the elements of the constructor, if a
1894 typespec was given, we already know the string length and want the one
1896 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1897 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1901 const_string = false;
1902 gfc_init_se (&length_se, NULL);
1903 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1904 gfc_charlen_type_node);
1905 ss->string_length = length_se.expr;
1906 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1907 gfc_add_block_to_block (&loop->post, &length_se.post);
1910 const_string = get_array_ctor_strlen (&loop->pre, c,
1911 &ss->string_length);
1913 /* Complex character array constructors should have been taken care of
1914 and not end up here. */
1915 gcc_assert (ss->string_length);
1917 ss->expr->ts.u.cl->backend_decl = ss->string_length;
1919 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1921 type = build_pointer_type (type);
1924 type = gfc_typenode_for_spec (&ss->expr->ts);
1926 /* See if the constructor determines the loop bounds. */
1929 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1931 /* We have a multidimensional parameter. */
1933 for (n = 0; n < ss->expr->rank; n++)
1935 loop->from[n] = gfc_index_zero_node;
1936 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1937 gfc_index_integer_kind);
1938 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
1939 gfc_array_index_type,
1940 loop->to[n], gfc_index_one_node);
1944 if (loop->to[0] == NULL_TREE)
1948 /* We should have a 1-dimensional, zero-based loop. */
1949 gcc_assert (loop->dimen == 1);
1950 gcc_assert (integer_zerop (loop->from[0]));
1952 /* Split the constructor size into a static part and a dynamic part.
1953 Allocate the static size up-front and record whether the dynamic
1954 size might be nonzero. */
1956 dynamic = gfc_get_array_constructor_size (&size, c);
1957 mpz_sub_ui (size, size, 1);
1958 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1962 /* Special case constant array constructors. */
1965 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1968 tree size = constant_array_constructor_loop_size (loop);
1969 if (size && compare_tree_int (size, nelem) == 0)
1971 gfc_trans_constant_array_constructor (loop, ss, type);
1977 if (TREE_CODE (loop->to[0]) == VAR_DECL)
1980 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1981 type, NULL_TREE, dynamic, true, false, where);
1983 desc = ss->data.info.descriptor;
1984 offset = gfc_index_zero_node;
1985 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1986 TREE_NO_WARNING (offsetvar) = 1;
1987 TREE_USED (offsetvar) = 0;
1988 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1989 &offset, &offsetvar, dynamic);
1991 /* If the array grows dynamically, the upper bound of the loop variable
1992 is determined by the array's final upper bound. */
1995 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1996 gfc_array_index_type,
1997 offsetvar, gfc_index_one_node);
1998 tmp = gfc_evaluate_now (tmp, &loop->pre);
1999 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2000 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2001 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2006 if (TREE_USED (offsetvar))
2007 pushdecl (offsetvar);
2009 gcc_assert (INTEGER_CST_P (offset));
2012 /* Disable bound checking for now because it's probably broken. */
2013 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2020 /* Restore old values of globals. */
2021 first_len = old_first_len;
2022 first_len_val = old_first_len_val;
2023 typespec_chararray_ctor = old_typespec_chararray_ctor;
2027 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2028 called after evaluating all of INFO's vector dimensions. Go through
2029 each such vector dimension and see if we can now fill in any missing
2033 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
2042 for (n = 0; n < loop->dimen + loop->codimen; n++)
2045 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2046 && loop->to[n] == NULL)
2048 /* Loop variable N indexes vector dimension DIM, and we don't
2049 yet know the upper bound of loop variable N. Set it to the
2050 difference between the vector's upper and lower bounds. */
2051 gcc_assert (loop->from[n] == gfc_index_zero_node);
2052 gcc_assert (info->subscript[dim]
2053 && info->subscript[dim]->type == GFC_SS_VECTOR);
2055 gfc_init_se (&se, NULL);
2056 desc = info->subscript[dim]->data.info.descriptor;
2057 zero = gfc_rank_cst[0];
2058 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2059 gfc_array_index_type,
2060 gfc_conv_descriptor_ubound_get (desc, zero),
2061 gfc_conv_descriptor_lbound_get (desc, zero));
2062 tmp = gfc_evaluate_now (tmp, &loop->pre);
2069 /* Add the pre and post chains for all the scalar expressions in a SS chain
2070 to loop. This is called after the loop parameters have been calculated,
2071 but before the actual scalarizing loops. */
2074 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2080 /* TODO: This can generate bad code if there are ordering dependencies,
2081 e.g., a callee allocated function and an unknown size constructor. */
2082 gcc_assert (ss != NULL);
2084 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2091 /* Scalar expression. Evaluate this now. This includes elemental
2092 dimension indices, but not array section bounds. */
2093 gfc_init_se (&se, NULL);
2094 gfc_conv_expr (&se, ss->expr);
2095 gfc_add_block_to_block (&loop->pre, &se.pre);
2097 if (ss->expr->ts.type != BT_CHARACTER)
2099 /* Move the evaluation of scalar expressions outside the
2100 scalarization loop, except for WHERE assignments. */
2102 se.expr = convert(gfc_array_index_type, se.expr);
2104 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2105 gfc_add_block_to_block (&loop->pre, &se.post);
2108 gfc_add_block_to_block (&loop->post, &se.post);
2110 ss->data.scalar.expr = se.expr;
2111 ss->string_length = se.string_length;
2114 case GFC_SS_REFERENCE:
2115 /* Scalar argument to elemental procedure. Evaluate this
2117 gfc_init_se (&se, NULL);
2118 gfc_conv_expr (&se, ss->expr);
2119 gfc_add_block_to_block (&loop->pre, &se.pre);
2120 gfc_add_block_to_block (&loop->post, &se.post);
2122 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2123 ss->string_length = se.string_length;
2126 case GFC_SS_SECTION:
2127 /* Add the expressions for scalar and vector subscripts. */
2128 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2129 if (ss->data.info.subscript[n])
2130 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2133 gfc_set_vector_loop_bounds (loop, &ss->data.info);
2137 /* Get the vector's descriptor and store it in SS. */
2138 gfc_init_se (&se, NULL);
2139 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2140 gfc_add_block_to_block (&loop->pre, &se.pre);
2141 gfc_add_block_to_block (&loop->post, &se.post);
2142 ss->data.info.descriptor = se.expr;
2145 case GFC_SS_INTRINSIC:
2146 gfc_add_intrinsic_ss_code (loop, ss);
2149 case GFC_SS_FUNCTION:
2150 /* Array function return value. We call the function and save its
2151 result in a temporary for use inside the loop. */
2152 gfc_init_se (&se, NULL);
2155 gfc_conv_expr (&se, ss->expr);
2156 gfc_add_block_to_block (&loop->pre, &se.pre);
2157 gfc_add_block_to_block (&loop->post, &se.post);
2158 ss->string_length = se.string_length;
2161 case GFC_SS_CONSTRUCTOR:
2162 if (ss->expr->ts.type == BT_CHARACTER
2163 && ss->string_length == NULL
2164 && ss->expr->ts.u.cl
2165 && ss->expr->ts.u.cl->length)
2167 gfc_init_se (&se, NULL);
2168 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2169 gfc_charlen_type_node);
2170 ss->string_length = se.expr;
2171 gfc_add_block_to_block (&loop->pre, &se.pre);
2172 gfc_add_block_to_block (&loop->post, &se.post);
2174 gfc_trans_array_constructor (loop, ss, where);
2178 case GFC_SS_COMPONENT:
2179 /* Do nothing. These are handled elsewhere. */
2189 /* Translate expressions for the descriptor and data pointer of a SS. */
2193 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2198 /* Get the descriptor for the array to be scalarized. */
2199 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2200 gfc_init_se (&se, NULL);
2201 se.descriptor_only = 1;
2202 gfc_conv_expr_lhs (&se, ss->expr);
2203 gfc_add_block_to_block (block, &se.pre);
2204 ss->data.info.descriptor = se.expr;
2205 ss->string_length = se.string_length;
2209 /* Also the data pointer. */
2210 tmp = gfc_conv_array_data (se.expr);
2211 /* If this is a variable or address of a variable we use it directly.
2212 Otherwise we must evaluate it now to avoid breaking dependency
2213 analysis by pulling the expressions for elemental array indices
2216 || (TREE_CODE (tmp) == ADDR_EXPR
2217 && DECL_P (TREE_OPERAND (tmp, 0)))))
2218 tmp = gfc_evaluate_now (tmp, block);
2219 ss->data.info.data = tmp;
2221 tmp = gfc_conv_array_offset (se.expr);
2222 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2224 /* Make absolutely sure that the saved_offset is indeed saved
2225 so that the variable is still accessible after the loops
2227 ss->data.info.saved_offset = ss->data.info.offset;
2232 /* Initialize a gfc_loopinfo structure. */
2235 gfc_init_loopinfo (gfc_loopinfo * loop)
2239 memset (loop, 0, sizeof (gfc_loopinfo));
2240 gfc_init_block (&loop->pre);
2241 gfc_init_block (&loop->post);
2243 /* Initially scalarize in order and default to no loop reversal. */
2244 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2247 loop->reverse[n] = GFC_CANNOT_REVERSE;
2250 loop->ss = gfc_ss_terminator;
2254 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2258 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2264 /* Return an expression for the data pointer of an array. */
2267 gfc_conv_array_data (tree descriptor)
2271 type = TREE_TYPE (descriptor);
2272 if (GFC_ARRAY_TYPE_P (type))
2274 if (TREE_CODE (type) == POINTER_TYPE)
2278 /* Descriptorless arrays. */
2279 return gfc_build_addr_expr (NULL_TREE, descriptor);
2283 return gfc_conv_descriptor_data_get (descriptor);
2287 /* Return an expression for the base offset of an array. */
2290 gfc_conv_array_offset (tree descriptor)
2294 type = TREE_TYPE (descriptor);
2295 if (GFC_ARRAY_TYPE_P (type))
2296 return GFC_TYPE_ARRAY_OFFSET (type);
2298 return gfc_conv_descriptor_offset_get (descriptor);
2302 /* Get an expression for the array stride. */
2305 gfc_conv_array_stride (tree descriptor, int dim)
2310 type = TREE_TYPE (descriptor);
2312 /* For descriptorless arrays use the array size. */
2313 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2314 if (tmp != NULL_TREE)
2317 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2322 /* Like gfc_conv_array_stride, but for the lower bound. */
2325 gfc_conv_array_lbound (tree descriptor, int dim)
2330 type = TREE_TYPE (descriptor);
2332 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2333 if (tmp != NULL_TREE)
2336 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2341 /* Like gfc_conv_array_stride, but for the upper bound. */
2344 gfc_conv_array_ubound (tree descriptor, int dim)
2349 type = TREE_TYPE (descriptor);
2351 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2352 if (tmp != NULL_TREE)
2355 /* This should only ever happen when passing an assumed shape array
2356 as an actual parameter. The value will never be used. */
2357 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2358 return gfc_index_zero_node;
2360 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2365 /* Generate code to perform an array index bound check. */
2368 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2369 locus * where, bool check_upper)
2372 tree tmp_lo, tmp_up;
2374 const char * name = NULL;
2376 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2379 index = gfc_evaluate_now (index, &se->pre);
2381 /* We find a name for the error message. */
2383 name = se->ss->expr->symtree->name;
2385 if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2386 && se->loop->ss->expr->symtree)
2387 name = se->loop->ss->expr->symtree->name;
2389 if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2390 && se->loop->ss->loop_chain->expr
2391 && se->loop->ss->loop_chain->expr->symtree)
2392 name = se->loop->ss->loop_chain->expr->symtree->name;
2394 if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2396 if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2397 && se->loop->ss->expr->value.function.name)
2398 name = se->loop->ss->expr->value.function.name;
2400 if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2401 || se->loop->ss->type == GFC_SS_SCALAR)
2402 name = "unnamed constant";
2405 if (TREE_CODE (descriptor) == VAR_DECL)
2406 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2408 /* If upper bound is present, include both bounds in the error message. */
2411 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2412 tmp_up = gfc_conv_array_ubound (descriptor, n);
2415 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2416 "outside of expected range (%%ld:%%ld)", n+1, name);
2418 asprintf (&msg, "Index '%%ld' of dimension %d "
2419 "outside of expected range (%%ld:%%ld)", n+1);
2421 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2423 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2424 fold_convert (long_integer_type_node, index),
2425 fold_convert (long_integer_type_node, tmp_lo),
2426 fold_convert (long_integer_type_node, tmp_up));
2427 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2429 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2430 fold_convert (long_integer_type_node, index),
2431 fold_convert (long_integer_type_node, tmp_lo),
2432 fold_convert (long_integer_type_node, tmp_up));
2437 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2440 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2441 "below lower bound of %%ld", n+1, name);
2443 asprintf (&msg, "Index '%%ld' of dimension %d "
2444 "below lower bound of %%ld", n+1);
2446 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2448 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2449 fold_convert (long_integer_type_node, index),
2450 fold_convert (long_integer_type_node, tmp_lo));
2458 /* Return the offset for an index. Performs bound checking for elemental
2459 dimensions. Single element references are processed separately.
2460 DIM is the array dimension, I is the loop dimension. */
2463 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2464 gfc_array_ref * ar, tree stride)
2470 /* Get the index into the array for this dimension. */
2473 gcc_assert (ar->type != AR_ELEMENT);
2474 switch (ar->dimen_type[dim])
2476 case DIMEN_THIS_IMAGE:
2480 /* Elemental dimension. */
2481 gcc_assert (info->subscript[dim]
2482 && info->subscript[dim]->type == GFC_SS_SCALAR);
2483 /* We've already translated this value outside the loop. */
2484 index = info->subscript[dim]->data.scalar.expr;
2486 index = gfc_trans_array_bound_check (se, info->descriptor,
2487 index, dim, &ar->where,
2488 ar->as->type != AS_ASSUMED_SIZE
2489 || dim < ar->dimen - 1);
2493 gcc_assert (info && se->loop);
2494 gcc_assert (info->subscript[dim]
2495 && info->subscript[dim]->type == GFC_SS_VECTOR);
2496 desc = info->subscript[dim]->data.info.descriptor;
2498 /* Get a zero-based index into the vector. */
2499 index = fold_build2_loc (input_location, MINUS_EXPR,
2500 gfc_array_index_type,
2501 se->loop->loopvar[i], se->loop->from[i]);
2503 /* Multiply the index by the stride. */
2504 index = fold_build2_loc (input_location, MULT_EXPR,
2505 gfc_array_index_type,
2506 index, gfc_conv_array_stride (desc, 0));
2508 /* Read the vector to get an index into info->descriptor. */
2509 data = build_fold_indirect_ref_loc (input_location,
2510 gfc_conv_array_data (desc));
2511 index = gfc_build_array_ref (data, index, NULL);
2512 index = gfc_evaluate_now (index, &se->pre);
2513 index = fold_convert (gfc_array_index_type, index);
2515 /* Do any bounds checking on the final info->descriptor index. */
2516 index = gfc_trans_array_bound_check (se, info->descriptor,
2517 index, dim, &ar->where,
2518 ar->as->type != AS_ASSUMED_SIZE
2519 || dim < ar->dimen - 1);
2523 /* Scalarized dimension. */
2524 gcc_assert (info && se->loop);
2526 /* Multiply the loop variable by the stride and delta. */
2527 index = se->loop->loopvar[i];
2528 if (!integer_onep (info->stride[dim]))
2529 index = fold_build2_loc (input_location, MULT_EXPR,
2530 gfc_array_index_type, index,
2532 if (!integer_zerop (info->delta[dim]))
2533 index = fold_build2_loc (input_location, PLUS_EXPR,
2534 gfc_array_index_type, index,
2544 /* Temporary array or derived type component. */
2545 gcc_assert (se->loop);
2546 index = se->loop->loopvar[se->loop->order[i]];
2547 if (!integer_zerop (info->delta[dim]))
2548 index = fold_build2_loc (input_location, PLUS_EXPR,
2549 gfc_array_index_type, index, info->delta[dim]);
2552 /* Multiply by the stride. */
2553 if (!integer_onep (stride))
2554 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2561 /* Build a scalarized reference to an array. */
2564 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2567 tree decl = NULL_TREE;
2572 info = &se->ss->data.info;
2574 n = se->loop->order[0];
2578 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2580 /* Add the offset for this dimension to the stored offset for all other
2582 if (!integer_zerop (info->offset))
2583 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2584 index, info->offset);
2586 if (se->ss->expr && is_subref_array (se->ss->expr))
2587 decl = se->ss->expr->symtree->n.sym->backend_decl;
2589 tmp = build_fold_indirect_ref_loc (input_location,
2591 se->expr = gfc_build_array_ref (tmp, index, decl);
2595 /* Translate access of temporary array. */
2598 gfc_conv_tmp_array_ref (gfc_se * se)
2600 se->string_length = se->ss->string_length;
2601 gfc_conv_scalarized_array_ref (se, NULL);
2602 gfc_advance_se_ss_chain (se);
2606 /* Build an array reference. se->expr already holds the array descriptor.
2607 This should be either a variable, indirect variable reference or component
2608 reference. For arrays which do not have a descriptor, se->expr will be
2610 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2613 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2625 gcc_assert (ar->codimen);
2626 /* Use the actual tree type and not the wrapped coarray. */
2627 se->expr = fold_convert (TREE_TYPE (TREE_TYPE (se->expr)), se->expr);
2631 /* Handle scalarized references separately. */
2632 if (ar->type != AR_ELEMENT)
2634 gfc_conv_scalarized_array_ref (se, ar);
2635 gfc_advance_se_ss_chain (se);
2639 index = gfc_index_zero_node;
2641 /* Calculate the offsets from all the dimensions. */
2642 for (n = 0; n < ar->dimen; n++)
2644 /* Calculate the index for this dimension. */
2645 gfc_init_se (&indexse, se);
2646 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2647 gfc_add_block_to_block (&se->pre, &indexse.pre);
2649 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2651 /* Check array bounds. */
2655 /* Evaluate the indexse.expr only once. */
2656 indexse.expr = save_expr (indexse.expr);
2659 tmp = gfc_conv_array_lbound (se->expr, n);
2660 if (sym->attr.temporary)
2662 gfc_init_se (&tmpse, se);
2663 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2664 gfc_array_index_type);
2665 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2669 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2671 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2672 "below lower bound of %%ld", n+1, sym->name);
2673 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2674 fold_convert (long_integer_type_node,
2676 fold_convert (long_integer_type_node, tmp));
2679 /* Upper bound, but not for the last dimension of assumed-size
2681 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2683 tmp = gfc_conv_array_ubound (se->expr, n);
2684 if (sym->attr.temporary)
2686 gfc_init_se (&tmpse, se);
2687 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2688 gfc_array_index_type);
2689 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2693 cond = fold_build2_loc (input_location, GT_EXPR,
2694 boolean_type_node, indexse.expr, tmp);
2695 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2696 "above upper bound of %%ld", n+1, sym->name);
2697 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2698 fold_convert (long_integer_type_node,
2700 fold_convert (long_integer_type_node, tmp));
2705 /* Multiply the index by the stride. */
2706 stride = gfc_conv_array_stride (se->expr, n);
2707 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2708 indexse.expr, stride);
2710 /* And add it to the total. */
2711 index = fold_build2_loc (input_location, PLUS_EXPR,
2712 gfc_array_index_type, index, tmp);
2715 tmp = gfc_conv_array_offset (se->expr);
2716 if (!integer_zerop (tmp))
2717 index = fold_build2_loc (input_location, PLUS_EXPR,
2718 gfc_array_index_type, index, tmp);
2720 /* Access the calculated element. */
2721 tmp = gfc_conv_array_data (se->expr);
2722 tmp = build_fold_indirect_ref (tmp);
2723 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2727 /* Generate the code to be executed immediately before entering a
2728 scalarization loop. */
2731 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2732 stmtblock_t * pblock)
2741 /* This code will be executed before entering the scalarization loop
2742 for this dimension. */
2743 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2745 if ((ss->useflags & flag) == 0)
2748 if (ss->type != GFC_SS_SECTION
2749 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2750 && ss->type != GFC_SS_COMPONENT)
2753 info = &ss->data.info;
2755 if (dim >= info->dimen)
2758 if (dim == info->dimen - 1)
2760 /* For the outermost loop calculate the offset due to any
2761 elemental dimensions. It will have been initialized with the
2762 base offset of the array. */
2765 for (i = 0; i < info->ref->u.ar.dimen; i++)
2767 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2770 gfc_init_se (&se, NULL);
2772 se.expr = info->descriptor;
2773 stride = gfc_conv_array_stride (info->descriptor, i);
2774 index = gfc_conv_array_index_offset (&se, info, i, -1,
2777 gfc_add_block_to_block (pblock, &se.pre);
2779 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2780 gfc_array_index_type,
2781 info->offset, index);
2782 info->offset = gfc_evaluate_now (info->offset, pblock);
2787 /* For the time being, the innermost loop is unconditionally on
2788 the first dimension of the scalarization loop. */
2789 gcc_assert (i == 0);
2790 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2792 /* Calculate the stride of the innermost loop. Hopefully this will
2793 allow the backend optimizers to do their stuff more effectively.
2795 info->stride0 = gfc_evaluate_now (stride, pblock);
2799 /* Add the offset for the previous loop dimension. */
2804 ar = &info->ref->u.ar;
2805 i = loop->order[dim + 1];
2813 gfc_init_se (&se, NULL);
2815 se.expr = info->descriptor;
2816 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2817 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2819 gfc_add_block_to_block (pblock, &se.pre);
2820 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2821 gfc_array_index_type, info->offset,
2823 info->offset = gfc_evaluate_now (info->offset, pblock);
2826 /* Remember this offset for the second loop. */
2827 if (dim == loop->temp_dim - 1)
2828 info->saved_offset = info->offset;
2833 /* Start a scalarized expression. Creates a scope and declares loop
2837 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2843 gcc_assert (!loop->array_parameter);
2845 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2847 n = loop->order[dim];
2849 gfc_start_block (&loop->code[n]);
2851 /* Create the loop variable. */
2852 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2854 if (dim < loop->temp_dim)
2858 /* Calculate values that will be constant within this loop. */
2859 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2861 gfc_start_block (pbody);
2865 /* Generates the actual loop code for a scalarization loop. */
2868 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2869 stmtblock_t * pbody)
2880 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2881 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2882 && n == loop->dimen - 1)
2884 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2885 init = make_tree_vec (1);
2886 cond = make_tree_vec (1);
2887 incr = make_tree_vec (1);
2889 /* Cycle statement is implemented with a goto. Exit statement must not
2890 be present for this loop. */
2891 exit_label = gfc_build_label_decl (NULL_TREE);
2892 TREE_USED (exit_label) = 1;
2894 /* Label for cycle statements (if needed). */
2895 tmp = build1_v (LABEL_EXPR, exit_label);
2896 gfc_add_expr_to_block (pbody, tmp);
2898 stmt = make_node (OMP_FOR);
2900 TREE_TYPE (stmt) = void_type_node;
2901 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2903 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2904 OMP_CLAUSE_SCHEDULE);
2905 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2906 = OMP_CLAUSE_SCHEDULE_STATIC;
2907 if (ompws_flags & OMPWS_NOWAIT)
2908 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2909 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2911 /* Initialize the loopvar. */
2912 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2914 OMP_FOR_INIT (stmt) = init;
2915 /* The exit condition. */
2916 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2918 loop->loopvar[n], loop->to[n]);
2919 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2920 OMP_FOR_COND (stmt) = cond;
2921 /* Increment the loopvar. */
2922 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2923 loop->loopvar[n], gfc_index_one_node);
2924 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2925 void_type_node, loop->loopvar[n], tmp);
2926 OMP_FOR_INCR (stmt) = incr;
2928 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2929 gfc_add_expr_to_block (&loop->code[n], stmt);
2933 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2934 && (loop->temp_ss == NULL);
2936 loopbody = gfc_finish_block (pbody);
2940 tmp = loop->from[n];
2941 loop->from[n] = loop->to[n];
2945 /* Initialize the loopvar. */
2946 if (loop->loopvar[n] != loop->from[n])
2947 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2949 exit_label = gfc_build_label_decl (NULL_TREE);
2951 /* Generate the loop body. */
2952 gfc_init_block (&block);
2954 /* The exit condition. */
2955 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2956 boolean_type_node, loop->loopvar[n], loop->to[n]);
2957 tmp = build1_v (GOTO_EXPR, exit_label);
2958 TREE_USED (exit_label) = 1;
2959 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2960 gfc_add_expr_to_block (&block, tmp);
2962 /* The main body. */
2963 gfc_add_expr_to_block (&block, loopbody);
2965 /* Increment the loopvar. */
2966 tmp = fold_build2_loc (input_location,
2967 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2968 gfc_array_index_type, loop->loopvar[n],
2969 gfc_index_one_node);
2971 gfc_add_modify (&block, loop->loopvar[n], tmp);
2973 /* Build the loop. */
2974 tmp = gfc_finish_block (&block);
2975 tmp = build1_v (LOOP_EXPR, tmp);
2976 gfc_add_expr_to_block (&loop->code[n], tmp);
2978 /* Add the exit label. */
2979 tmp = build1_v (LABEL_EXPR, exit_label);
2980 gfc_add_expr_to_block (&loop->code[n], tmp);
2986 /* Finishes and generates the loops for a scalarized expression. */
2989 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2994 stmtblock_t *pblock;
2998 /* Generate the loops. */
2999 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
3001 n = loop->order[dim];
3002 gfc_trans_scalarized_loop_end (loop, n, pblock);
3003 loop->loopvar[n] = NULL_TREE;
3004 pblock = &loop->code[n];
3007 tmp = gfc_finish_block (pblock);
3008 gfc_add_expr_to_block (&loop->pre, tmp);
3010 /* Clear all the used flags. */
3011 for (ss = loop->ss; ss; ss = ss->loop_chain)
3016 /* Finish the main body of a scalarized expression, and start the secondary
3020 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3024 stmtblock_t *pblock;
3028 /* We finish as many loops as are used by the temporary. */
3029 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3031 n = loop->order[dim];
3032 gfc_trans_scalarized_loop_end (loop, n, pblock);
3033 loop->loopvar[n] = NULL_TREE;
3034 pblock = &loop->code[n];
3037 /* We don't want to finish the outermost loop entirely. */
3038 n = loop->order[loop->temp_dim - 1];
3039 gfc_trans_scalarized_loop_end (loop, n, pblock);
3041 /* Restore the initial offsets. */
3042 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3044 if ((ss->useflags & 2) == 0)
3047 if (ss->type != GFC_SS_SECTION
3048 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3049 && ss->type != GFC_SS_COMPONENT)
3052 ss->data.info.offset = ss->data.info.saved_offset;
3055 /* Restart all the inner loops we just finished. */
3056 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3058 n = loop->order[dim];
3060 gfc_start_block (&loop->code[n]);
3062 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3064 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3067 /* Start a block for the secondary copying code. */
3068 gfc_start_block (body);
3072 /* Calculate the lower bound of an array section. */
3075 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3076 bool coarray, bool coarray_last)
3080 gfc_expr *stride = NULL;
3085 gcc_assert (ss->type == GFC_SS_SECTION);
3087 info = &ss->data.info;
3089 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3091 /* We use a zero-based index to access the vector. */
3092 info->start[dim] = gfc_index_zero_node;
3093 info->end[dim] = NULL;
3095 info->stride[dim] = gfc_index_one_node;
3099 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3100 desc = info->descriptor;
3101 start = info->ref->u.ar.start[dim];
3102 end = info->ref->u.ar.end[dim];
3104 stride = info->ref->u.ar.stride[dim];
3106 /* Calculate the start of the range. For vector subscripts this will
3107 be the range of the vector. */
3110 /* Specified section start. */
3111 gfc_init_se (&se, NULL);
3112 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3113 gfc_add_block_to_block (&loop->pre, &se.pre);
3114 info->start[dim] = se.expr;
3118 /* No lower bound specified so use the bound of the array. */
3119 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3121 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3123 /* Similarly calculate the end. Although this is not used in the
3124 scalarizer, it is needed when checking bounds and where the end
3125 is an expression with side-effects. */
3130 /* Specified section start. */
3131 gfc_init_se (&se, NULL);
3132 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3133 gfc_add_block_to_block (&loop->pre, &se.pre);
3134 info->end[dim] = se.expr;
3138 /* No upper bound specified so use the bound of the array. */
3139 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3141 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3144 /* Calculate the stride. */
3145 if (!coarray && stride == NULL)
3146 info->stride[dim] = gfc_index_one_node;
3149 gfc_init_se (&se, NULL);
3150 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3151 gfc_add_block_to_block (&loop->pre, &se.pre);
3152 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3157 /* Calculates the range start and stride for a SS chain. Also gets the
3158 descriptor and data pointer. The range of vector subscripts is the size
3159 of the vector. Array bounds are also checked. */
3162 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3170 /* Determine the rank of the loop. */
3172 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3176 case GFC_SS_SECTION:
3177 case GFC_SS_CONSTRUCTOR:
3178 case GFC_SS_FUNCTION:
3179 case GFC_SS_COMPONENT:
3180 loop->dimen = ss->data.info.dimen;
3181 loop->codimen = ss->data.info.codimen;
3184 /* As usual, lbound and ubound are exceptions!. */
3185 case GFC_SS_INTRINSIC:
3186 switch (ss->expr->value.function.isym->id)
3188 case GFC_ISYM_LBOUND:
3189 case GFC_ISYM_UBOUND:
3190 loop->dimen = ss->data.info.dimen;
3194 case GFC_ISYM_LCOBOUND:
3195 case GFC_ISYM_UCOBOUND:
3196 case GFC_ISYM_THIS_IMAGE:
3197 loop->dimen = ss->data.info.dimen;
3198 loop->codimen = ss->data.info.codimen;
3210 /* We should have determined the rank of the expression by now. If
3211 not, that's bad news. */
3212 gcc_assert (loop->dimen + loop->codimen != 0);
3214 /* Loop over all the SS in the chain. */
3215 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3217 if (ss->expr && ss->expr->shape && !ss->shape)
3218 ss->shape = ss->expr->shape;
3222 case GFC_SS_SECTION:
3223 /* Get the descriptor for the array. */
3224 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3226 for (n = 0; n < ss->data.info.dimen; n++)
3227 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3229 for (n = ss->data.info.dimen;
3230 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3231 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3232 n == ss->data.info.dimen
3233 + ss->data.info.codimen -1);
3237 case GFC_SS_INTRINSIC:
3238 switch (ss->expr->value.function.isym->id)
3240 /* Fall through to supply start and stride. */
3241 case GFC_ISYM_LBOUND:
3242 case GFC_ISYM_UBOUND:
3243 case GFC_ISYM_LCOBOUND:
3244 case GFC_ISYM_UCOBOUND:
3245 case GFC_ISYM_THIS_IMAGE:
3252 case GFC_SS_CONSTRUCTOR:
3253 case GFC_SS_FUNCTION:
3254 for (n = 0; n < ss->data.info.dimen; n++)
3256 ss->data.info.start[n] = gfc_index_zero_node;
3257 ss->data.info.end[n] = gfc_index_zero_node;
3258 ss->data.info.stride[n] = gfc_index_one_node;
3267 /* The rest is just runtime bound checking. */
3268 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3271 tree lbound, ubound;
3273 tree size[GFC_MAX_DIMENSIONS];
3274 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3279 gfc_start_block (&block);
3281 for (n = 0; n < loop->dimen; n++)
3282 size[n] = NULL_TREE;
3284 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3288 if (ss->type != GFC_SS_SECTION)
3291 /* Catch allocatable lhs in f2003. */
3292 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3295 gfc_start_block (&inner);
3297 /* TODO: range checking for mapped dimensions. */
3298 info = &ss->data.info;
3300 /* This code only checks ranges. Elemental and vector
3301 dimensions are checked later. */
3302 for (n = 0; n < loop->dimen; n++)
3307 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3310 if (dim == info->ref->u.ar.dimen - 1
3311 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3312 check_upper = false;
3316 /* Zero stride is not allowed. */
3317 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3318 info->stride[dim], gfc_index_zero_node);
3319 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3320 "of array '%s'", dim + 1, ss->expr->symtree->name);
3321 gfc_trans_runtime_check (true, false, tmp, &inner,
3322 &ss->expr->where, msg);
3325 desc = ss->data.info.descriptor;
3327 /* This is the run-time equivalent of resolve.c's
3328 check_dimension(). The logical is more readable there
3329 than it is here, with all the trees. */
3330 lbound = gfc_conv_array_lbound (desc, dim);
3331 end = info->end[dim];
3333 ubound = gfc_conv_array_ubound (desc, dim);
3337 /* non_zerosized is true when the selected range is not
3339 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3340 boolean_type_node, info->stride[dim],
3341 gfc_index_zero_node);
3342 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3343 info->start[dim], end);
3344 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3345 boolean_type_node, stride_pos, tmp);
3347 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3349 info->stride[dim], gfc_index_zero_node);
3350 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3351 info->start[dim], end);
3352 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3355 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3357 stride_pos, stride_neg);
3359 /* Check the start of the range against the lower and upper
3360 bounds of the array, if the range is not empty.
3361 If upper bound is present, include both bounds in the
3365 tmp = fold_build2_loc (input_location, LT_EXPR,
3367 info->start[dim], lbound);
3368 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3370 non_zerosized, tmp);
3371 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3373 info->start[dim], ubound);
3374 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3376 non_zerosized, tmp2);
3377 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3378 "outside of expected range (%%ld:%%ld)",
3379 dim + 1, ss->expr->symtree->name);
3380 gfc_trans_runtime_check (true, false, tmp, &inner,
3381 &ss->expr->where, msg,
3382 fold_convert (long_integer_type_node, info->start[dim]),
3383 fold_convert (long_integer_type_node, lbound),
3384 fold_convert (long_integer_type_node, ubound));
3385 gfc_trans_runtime_check (true, false, tmp2, &inner,
3386 &ss->expr->where, msg,
3387 fold_convert (long_integer_type_node, info->start[dim]),
3388 fold_convert (long_integer_type_node, lbound),
3389 fold_convert (long_integer_type_node, ubound));
3394 tmp = fold_build2_loc (input_location, LT_EXPR,
3396 info->start[dim], lbound);
3397 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3398 boolean_type_node, non_zerosized, tmp);
3399 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3400 "below lower bound of %%ld",
3401 dim + 1, ss->expr->symtree->name);
3402 gfc_trans_runtime_check (true, false, tmp, &inner,
3403 &ss->expr->where, msg,
3404 fold_convert (long_integer_type_node, info->start[dim]),
3405 fold_convert (long_integer_type_node, lbound));
3409 /* Compute the last element of the range, which is not
3410 necessarily "end" (think 0:5:3, which doesn't contain 5)
3411 and check it against both lower and upper bounds. */
3413 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3414 gfc_array_index_type, end,
3416 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3417 gfc_array_index_type, tmp,
3419 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3420 gfc_array_index_type, end, tmp);
3421 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3422 boolean_type_node, tmp, lbound);
3423 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3424 boolean_type_node, non_zerosized, tmp2);
3427 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3428 boolean_type_node, tmp, ubound);
3429 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3430 boolean_type_node, non_zerosized, tmp3);
3431 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3432 "outside of expected range (%%ld:%%ld)",
3433 dim + 1, ss->expr->symtree->name);
3434 gfc_trans_runtime_check (true, false, tmp2, &inner,
3435 &ss->expr->where, msg,
3436 fold_convert (long_integer_type_node, tmp),
3437 fold_convert (long_integer_type_node, ubound),
3438 fold_convert (long_integer_type_node, lbound));
3439 gfc_trans_runtime_check (true, false, tmp3, &inner,
3440 &ss->expr->where, msg,
3441 fold_convert (long_integer_type_node, tmp),
3442 fold_convert (long_integer_type_node, ubound),
3443 fold_convert (long_integer_type_node, lbound));
3448 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3449 "below lower bound of %%ld",
3450 dim + 1, ss->expr->symtree->name);
3451 gfc_trans_runtime_check (true, false, tmp2, &inner,
3452 &ss->expr->where, msg,
3453 fold_convert (long_integer_type_node, tmp),
3454 fold_convert (long_integer_type_node, lbound));
3458 /* Check the section sizes match. */
3459 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3460 gfc_array_index_type, end,
3462 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3463 gfc_array_index_type, tmp,
3465 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3466 gfc_array_index_type,
3467 gfc_index_one_node, tmp);
3468 tmp = fold_build2_loc (input_location, MAX_EXPR,
3469 gfc_array_index_type, tmp,
3470 build_int_cst (gfc_array_index_type, 0));
3471 /* We remember the size of the first section, and check all the
3472 others against this. */
3475 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3476 boolean_type_node, tmp, size[n]);
3477 asprintf (&msg, "Array bound mismatch for dimension %d "
3478 "of array '%s' (%%ld/%%ld)",
3479 dim + 1, ss->expr->symtree->name);
3481 gfc_trans_runtime_check (true, false, tmp3, &inner,
3482 &ss->expr->where, msg,
3483 fold_convert (long_integer_type_node, tmp),
3484 fold_convert (long_integer_type_node, size[n]));
3489 size[n] = gfc_evaluate_now (tmp, &inner);
3492 tmp = gfc_finish_block (&inner);
3494 /* For optional arguments, only check bounds if the argument is
3496 if (ss->expr->symtree->n.sym->attr.optional
3497 || ss->expr->symtree->n.sym->attr.not_always_present)
3498 tmp = build3_v (COND_EXPR,
3499 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3500 tmp, build_empty_stmt (input_location));
3502 gfc_add_expr_to_block (&block, tmp);
3506 tmp = gfc_finish_block (&block);
3507 gfc_add_expr_to_block (&loop->pre, tmp);
3511 /* Return true if both symbols could refer to the same data object. Does
3512 not take account of aliasing due to equivalence statements. */
3515 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3516 bool lsym_target, bool rsym_pointer, bool rsym_target)
3518 /* Aliasing isn't possible if the symbols have different base types. */
3519 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3522 /* Pointers can point to other pointers and target objects. */
3524 if ((lsym_pointer && (rsym_pointer || rsym_target))
3525 || (rsym_pointer && (lsym_pointer || lsym_target)))
3528 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3529 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3531 if (lsym_target && rsym_target
3532 && ((lsym->attr.dummy && !lsym->attr.contiguous
3533 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3534 || (rsym->attr.dummy && !rsym->attr.contiguous
3535 && (!rsym->attr.dimension
3536 || rsym->as->type == AS_ASSUMED_SHAPE))))
3543 /* Return true if the two SS could be aliased, i.e. both point to the same data
3545 /* TODO: resolve aliases based on frontend expressions. */
3548 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3554 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3556 lsym = lss->expr->symtree->n.sym;
3557 rsym = rss->expr->symtree->n.sym;
3559 lsym_pointer = lsym->attr.pointer;
3560 lsym_target = lsym->attr.target;
3561 rsym_pointer = rsym->attr.pointer;
3562 rsym_target = rsym->attr.target;
3564 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3565 rsym_pointer, rsym_target))
3568 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3569 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3572 /* For derived types we must check all the component types. We can ignore
3573 array references as these will have the same base type as the previous
3575 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3577 if (lref->type != REF_COMPONENT)
3580 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3581 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3583 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3584 rsym_pointer, rsym_target))
3587 if ((lsym_pointer && (rsym_pointer || rsym_target))
3588 || (rsym_pointer && (lsym_pointer || lsym_target)))
3590 if (gfc_compare_types (&lref->u.c.component->ts,
3595 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3598 if (rref->type != REF_COMPONENT)
3601 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3602 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3604 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3605 lsym_pointer, lsym_target,
3606 rsym_pointer, rsym_target))
3609 if ((lsym_pointer && (rsym_pointer || rsym_target))
3610 || (rsym_pointer && (lsym_pointer || lsym_target)))
3612 if (gfc_compare_types (&lref->u.c.component->ts,
3613 &rref->u.c.sym->ts))
3615 if (gfc_compare_types (&lref->u.c.sym->ts,
3616 &rref->u.c.component->ts))
3618 if (gfc_compare_types (&lref->u.c.component->ts,
3619 &rref->u.c.component->ts))
3625 lsym_pointer = lsym->attr.pointer;
3626 lsym_target = lsym->attr.target;
3627 lsym_pointer = lsym->attr.pointer;
3628 lsym_target = lsym->attr.target;
3630 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3632 if (rref->type != REF_COMPONENT)
3635 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3636 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3638 if (symbols_could_alias (rref->u.c.sym, lsym,
3639 lsym_pointer, lsym_target,
3640 rsym_pointer, rsym_target))
3643 if ((lsym_pointer && (rsym_pointer || rsym_target))
3644 || (rsym_pointer && (lsym_pointer || lsym_target)))
3646 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3655 /* Resolve array data dependencies. Creates a temporary if required. */
3656 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3660 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3669 loop->temp_ss = NULL;
3671 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3673 if (ss->type != GFC_SS_SECTION)
3676 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3678 if (gfc_could_be_alias (dest, ss)
3679 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3687 lref = dest->expr->ref;
3688 rref = ss->expr->ref;
3690 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3695 for (i = 0; i < dest->data.info.dimen; i++)
3696 for (j = 0; j < ss->data.info.dimen; j++)
3698 && dest->data.info.dim[i] == ss->data.info.dim[j])
3700 /* If we don't access array elements in the same order,
3701 there is a dependency. */
3706 /* TODO : loop shifting. */
3709 /* Mark the dimensions for LOOP SHIFTING */
3710 for (n = 0; n < loop->dimen; n++)
3712 int dim = dest->data.info.dim[n];
3714 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3716 else if (! gfc_is_same_range (&lref->u.ar,
3717 &rref->u.ar, dim, 0))
3721 /* Put all the dimensions with dependencies in the
3724 for (n = 0; n < loop->dimen; n++)
3726 gcc_assert (loop->order[n] == n);
3728 loop->order[dim++] = n;
3730 for (n = 0; n < loop->dimen; n++)
3733 loop->order[dim++] = n;
3736 gcc_assert (dim == loop->dimen);
3747 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3748 if (GFC_ARRAY_TYPE_P (base_type)
3749 || GFC_DESCRIPTOR_TYPE_P (base_type))
3750 base_type = gfc_get_element_type (base_type);
3751 loop->temp_ss = gfc_get_ss ();
3752 loop->temp_ss->type = GFC_SS_TEMP;
3753 loop->temp_ss->data.temp.type = base_type;
3754 loop->temp_ss->string_length = dest->string_length;
3755 loop->temp_ss->data.temp.dimen = loop->dimen;
3756 loop->temp_ss->data.temp.codimen = loop->codimen;
3757 loop->temp_ss->next = gfc_ss_terminator;
3758 gfc_add_ss_to_loop (loop, loop->temp_ss);
3761 loop->temp_ss = NULL;
3765 /* Initialize the scalarization loop. Creates the loop variables. Determines
3766 the range of the loop variables. Creates a temporary if required.
3767 Calculates how to transform from loop variables to array indices for each
3768 expression. Also generates code for scalar expressions which have been
3769 moved outside the loop. */
3772 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3774 int n, dim, spec_dim;
3776 gfc_ss_info *specinfo;
3779 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3780 bool dynamic[GFC_MAX_DIMENSIONS];
3785 for (n = 0; n < loop->dimen + loop->codimen; n++)
3789 /* We use one SS term, and use that to determine the bounds of the
3790 loop for this dimension. We try to pick the simplest term. */
3791 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3793 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3796 info = &ss->data.info;
3799 if (loopspec[n] != NULL)
3801 specinfo = &loopspec[n]->data.info;
3802 spec_dim = specinfo->dim[n];
3806 /* Silence unitialized warnings. */
3813 gcc_assert (ss->shape[dim]);
3814 /* The frontend has worked out the size for us. */
3816 || !loopspec[n]->shape
3817 || !integer_zerop (specinfo->start[spec_dim]))
3818 /* Prefer zero-based descriptors if possible. */
3823 if (ss->type == GFC_SS_CONSTRUCTOR)
3825 gfc_constructor_base base;
3826 /* An unknown size constructor will always be rank one.
3827 Higher rank constructors will either have known shape,
3828 or still be wrapped in a call to reshape. */
3829 gcc_assert (loop->dimen == 1);
3831 /* Always prefer to use the constructor bounds if the size
3832 can be determined at compile time. Prefer not to otherwise,
3833 since the general case involves realloc, and it's better to
3834 avoid that overhead if possible. */
3835 base = ss->expr->value.constructor;
3836 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3837 if (!dynamic[n] || !loopspec[n])
3842 /* TODO: Pick the best bound if we have a choice between a
3843 function and something else. */
3844 if (ss->type == GFC_SS_FUNCTION)
3850 /* Avoid using an allocatable lhs in an assignment, since
3851 there might be a reallocation coming. */
3852 if (loopspec[n] && ss->is_alloc_lhs)
3855 if (ss->type != GFC_SS_SECTION)
3860 /* Criteria for choosing a loop specifier (most important first):
3861 doesn't need realloc
3867 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3868 || n >= loop->dimen)
3870 else if (integer_onep (info->stride[dim])
3871 && !integer_onep (specinfo->stride[spec_dim]))
3873 else if (INTEGER_CST_P (info->stride[dim])
3874 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3876 else if (INTEGER_CST_P (info->start[dim])
3877 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3879 /* We don't work out the upper bound.
3880 else if (INTEGER_CST_P (info->finish[n])
3881 && ! INTEGER_CST_P (specinfo->finish[n]))
3882 loopspec[n] = ss; */
3885 /* We should have found the scalarization loop specifier. If not,
3887 gcc_assert (loopspec[n]);
3889 info = &loopspec[n]->data.info;
3892 /* Set the extents of this range. */
3893 cshape = loopspec[n]->shape;
3894 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3895 && INTEGER_CST_P (info->stride[dim]))
3897 loop->from[n] = info->start[dim];
3898 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3899 mpz_sub_ui (i, i, 1);
3900 /* To = from + (size - 1) * stride. */
3901 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3902 if (!integer_onep (info->stride[dim]))
3903 tmp = fold_build2_loc (input_location, MULT_EXPR,
3904 gfc_array_index_type, tmp,
3906 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3907 gfc_array_index_type,
3908 loop->from[n], tmp);
3912 loop->from[n] = info->start[dim];
3913 switch (loopspec[n]->type)
3915 case GFC_SS_CONSTRUCTOR:
3916 /* The upper bound is calculated when we expand the
3918 gcc_assert (loop->to[n] == NULL_TREE);
3921 case GFC_SS_SECTION:
3922 /* Use the end expression if it exists and is not constant,
3923 so that it is only evaluated once. */
3924 loop->to[n] = info->end[dim];
3927 case GFC_SS_FUNCTION:
3928 /* The loop bound will be set when we generate the call. */
3929 gcc_assert (loop->to[n] == NULL_TREE);
3937 /* Transform everything so we have a simple incrementing variable. */
3938 if (n < loop->dimen && integer_onep (info->stride[dim]))
3939 info->delta[dim] = gfc_index_zero_node;
3940 else if (n < loop->dimen)
3942 /* Set the delta for this section. */
3943 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3944 /* Number of iterations is (end - start + step) / step.
3945 with start = 0, this simplifies to
3947 for (i = 0; i<=last; i++){...}; */
3948 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3949 gfc_array_index_type, loop->to[n],
3951 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3952 gfc_array_index_type, tmp, info->stride[dim]);
3953 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3954 tmp, build_int_cst (gfc_array_index_type, -1));
3955 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3956 /* Make the loop variable start at 0. */
3957 loop->from[n] = gfc_index_zero_node;
3961 /* Add all the scalar code that can be taken out of the loops.
3962 This may include calculating the loop bounds, so do it before
3963 allocating the temporary. */
3964 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3966 /* If we want a temporary then create it. */
3967 if (loop->temp_ss != NULL)
3969 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3971 /* Make absolutely sure that this is a complete type. */
3972 if (loop->temp_ss->string_length)
3973 loop->temp_ss->data.temp.type
3974 = gfc_get_character_type_len_for_eltype
3975 (TREE_TYPE (loop->temp_ss->data.temp.type),
3976 loop->temp_ss->string_length);
3978 tmp = loop->temp_ss->data.temp.type;
3979 n = loop->temp_ss->data.temp.dimen;
3980 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3981 loop->temp_ss->type = GFC_SS_SECTION;
3982 loop->temp_ss->data.info.dimen = n;
3984 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3985 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3986 loop->temp_ss->data.info.dim[n] = n;
3988 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3989 &loop->temp_ss->data.info, tmp, NULL_TREE,
3990 false, true, false, where);
3993 for (n = 0; n < loop->temp_dim; n++)
3994 loopspec[loop->order[n]] = NULL;
3998 /* For array parameters we don't have loop variables, so don't calculate the
4000 if (loop->array_parameter)
4003 /* Calculate the translation from loop variables to array indices. */
4004 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4006 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4007 && ss->type != GFC_SS_CONSTRUCTOR)
4011 info = &ss->data.info;
4013 for (n = 0; n < info->dimen; n++)
4015 /* If we are specifying the range the delta is already set. */
4016 if (loopspec[n] != ss)
4018 dim = ss->data.info.dim[n];
4020 /* Calculate the offset relative to the loop variable.
4021 First multiply by the stride. */
4022 tmp = loop->from[n];
4023 if (!integer_onep (info->stride[dim]))
4024 tmp = fold_build2_loc (input_location, MULT_EXPR,
4025 gfc_array_index_type,
4026 tmp, info->stride[dim]);
4028 /* Then subtract this from our starting value. */
4029 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4030 gfc_array_index_type,
4031 info->start[dim], tmp);
4033 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4040 /* Calculate the size of a given array dimension from the bounds. This
4041 is simply (ubound - lbound + 1) if this expression is positive
4042 or 0 if it is negative (pick either one if it is zero). Optionally
4043 (if or_expr is present) OR the (expression != 0) condition to it. */
4046 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4051 /* Calculate (ubound - lbound + 1). */
4052 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4054 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4055 gfc_index_one_node);
4057 /* Check whether the size for this dimension is negative. */
4058 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4059 gfc_index_zero_node);
4060 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4061 gfc_index_zero_node, res);
4063 /* Build OR expression. */
4065 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4066 boolean_type_node, *or_expr, cond);
4072 /* For an array descriptor, get the total number of elements. This is just
4073 the product of the extents along from_dim to to_dim. */
4076 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4081 res = gfc_index_one_node;
4083 for (dim = from_dim; dim < to_dim; ++dim)
4089 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4090 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4092 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4093 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4101 /* Full size of an array. */
4104 gfc_conv_descriptor_size (tree desc, int rank)
4106 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4110 /* Size of a coarray for all dimensions but the last. */
4113 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4115 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4119 /* Fills in an array descriptor, and returns the size of the array.
4120 The size will be a simple_val, ie a variable or a constant. Also
4121 calculates the offset of the base. The pointer argument overflow,
4122 which should be of integer type, will increase in value if overflow
4123 occurs during the size calculation. Returns the size of the array.
4127 for (n = 0; n < rank; n++)
4129 a.lbound[n] = specified_lower_bound;
4130 offset = offset + a.lbond[n] * stride;
4132 a.ubound[n] = specified_upper_bound;
4133 a.stride[n] = stride;
4134 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4135 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4136 stride = stride * size;
4138 element_size = sizeof (array element);
4139 stride = (size_t) stride;
4140 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4141 stride = stride * element_size;
4147 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4148 gfc_expr ** lower, gfc_expr ** upper,
4149 stmtblock_t * pblock, tree * overflow)
4162 stmtblock_t thenblock;
4163 stmtblock_t elseblock;
4168 type = TREE_TYPE (descriptor);
4170 stride = gfc_index_one_node;
4171 offset = gfc_index_zero_node;
4173 /* Set the dtype. */
4174 tmp = gfc_conv_descriptor_dtype (descriptor);
4175 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4177 or_expr = boolean_false_node;
4179 for (n = 0; n < rank; n++)
4184 /* We have 3 possibilities for determining the size of the array:
4185 lower == NULL => lbound = 1, ubound = upper[n]
4186 upper[n] = NULL => lbound = 1, ubound = lower[n]
4187 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4190 /* Set lower bound. */
4191 gfc_init_se (&se, NULL);
4193 se.expr = gfc_index_one_node;
4196 gcc_assert (lower[n]);
4199 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4200 gfc_add_block_to_block (pblock, &se.pre);
4204 se.expr = gfc_index_one_node;
4208 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4210 conv_lbound = se.expr;
4212 /* Work out the offset for this component. */
4213 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4215 offset = fold_build2_loc (input_location, MINUS_EXPR,
4216 gfc_array_index_type, offset, tmp);
4218 /* Set upper bound. */
4219 gfc_init_se (&se, NULL);
4220 gcc_assert (ubound);
4221 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4222 gfc_add_block_to_block (pblock, &se.pre);
4224 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4225 gfc_rank_cst[n], se.expr);
4226 conv_ubound = se.expr;
4228 /* Store the stride. */
4229 gfc_conv_descriptor_stride_set (pblock, descriptor,
4230 gfc_rank_cst[n], stride);
4232 /* Calculate size and check whether extent is negative. */
4233 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4234 size = gfc_evaluate_now (size, pblock);
4236 /* Check whether multiplying the stride by the number of
4237 elements in this dimension would overflow. We must also check
4238 whether the current dimension has zero size in order to avoid
4241 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4242 gfc_array_index_type,
4243 fold_convert (gfc_array_index_type,
4244 TYPE_MAX_VALUE (gfc_array_index_type)),
4246 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4247 boolean_type_node, tmp, stride));
4248 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4249 integer_one_node, integer_zero_node);
4250 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4251 boolean_type_node, size,
4252 gfc_index_zero_node));
4253 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4254 integer_zero_node, tmp);
4255 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4257 *overflow = gfc_evaluate_now (tmp, pblock);
4259 /* Multiply the stride by the number of elements in this dimension. */
4260 stride = fold_build2_loc (input_location, MULT_EXPR,
4261 gfc_array_index_type, stride, size);
4262 stride = gfc_evaluate_now (stride, pblock);
4265 for (n = rank; n < rank + corank; n++)
4269 /* Set lower bound. */
4270 gfc_init_se (&se, NULL);
4271 if (lower == NULL || lower[n] == NULL)
4273 gcc_assert (n == rank + corank - 1);
4274 se.expr = gfc_index_one_node;
4278 if (ubound || n == rank + corank - 1)
4280 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4281 gfc_add_block_to_block (pblock, &se.pre);
4285 se.expr = gfc_index_one_node;
4289 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4292 if (n < rank + corank - 1)
4294 gfc_init_se (&se, NULL);
4295 gcc_assert (ubound);
4296 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4297 gfc_add_block_to_block (pblock, &se.pre);
4298 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4299 gfc_rank_cst[n], se.expr);
4303 /* The stride is the number of elements in the array, so multiply by the
4304 size of an element to get the total size. */
4305 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4306 /* Convert to size_t. */
4307 element_size = fold_convert (size_type_node, tmp);
4308 stride = fold_convert (size_type_node, stride);
4310 /* First check for overflow. Since an array of type character can
4311 have zero element_size, we must check for that before
4313 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4315 TYPE_MAX_VALUE (size_type_node), element_size);
4316 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4317 boolean_type_node, tmp, stride));
4318 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4319 integer_one_node, integer_zero_node);
4320 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4321 boolean_type_node, element_size,
4322 build_int_cst (size_type_node, 0)));
4323 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4324 integer_zero_node, tmp);
4325 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4327 *overflow = gfc_evaluate_now (tmp, pblock);
4329 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4330 stride, element_size);
4332 if (poffset != NULL)
4334 offset = gfc_evaluate_now (offset, pblock);
4338 if (integer_zerop (or_expr))
4340 if (integer_onep (or_expr))
4341 return build_int_cst (size_type_node, 0);
4343 var = gfc_create_var (TREE_TYPE (size), "size");
4344 gfc_start_block (&thenblock);
4345 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4346 thencase = gfc_finish_block (&thenblock);
4348 gfc_start_block (&elseblock);
4349 gfc_add_modify (&elseblock, var, size);
4350 elsecase = gfc_finish_block (&elseblock);
4352 tmp = gfc_evaluate_now (or_expr, pblock);
4353 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4354 gfc_add_expr_to_block (pblock, tmp);
4360 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4361 the work for an ALLOCATE statement. */
4365 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4373 tree overflow; /* Boolean storing whether size calculation overflows. */
4376 stmtblock_t elseblock;
4379 gfc_ref *ref, *prev_ref = NULL;
4380 bool allocatable_array, coarray;
4384 /* Find the last reference in the chain. */
4385 while (ref && ref->next != NULL)
4387 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4388 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4393 if (ref == NULL || ref->type != REF_ARRAY)
4398 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4399 coarray = expr->symtree->n.sym->attr.codimension;
4403 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4404 coarray = prev_ref->u.c.component->attr.codimension;
4407 /* Return if this is a scalar coarray. */
4408 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4409 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4411 gcc_assert (coarray);
4415 /* Figure out the size of the array. */
4416 switch (ref->u.ar.type)
4422 upper = ref->u.ar.start;
4428 lower = ref->u.ar.start;
4429 upper = ref->u.ar.end;
4433 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4435 lower = ref->u.ar.as->lower;
4436 upper = ref->u.ar.as->upper;
4444 overflow = integer_zero_node;
4445 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4446 ref->u.ar.as->corank, &offset, lower, upper,
4447 &se->pre, &overflow);
4449 var_overflow = gfc_create_var (integer_type_node, "overflow");
4450 gfc_add_modify (&se->pre, var_overflow, overflow);
4452 /* Generate the block of code handling overflow. */
4453 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
4454 ("Integer overflow when calculating the amount of "
4455 "memory to allocate"));
4456 error = build_call_expr_loc (input_location,
4457 gfor_fndecl_runtime_error, 1, msg);
4459 if (pstat != NULL_TREE && !integer_zerop (pstat))
4461 /* Set the status variable if it's present. */
4462 stmtblock_t set_status_block;
4463 tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
4465 gfc_start_block (&set_status_block);
4466 gfc_add_modify (&set_status_block,
4467 fold_build1_loc (input_location, INDIRECT_REF,
4468 status_type, pstat),
4469 build_int_cst (status_type, LIBERROR_ALLOCATION));
4471 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4472 pstat, build_int_cst (TREE_TYPE (pstat), 0));
4473 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
4474 error, gfc_finish_block (&set_status_block));
4477 gfc_start_block (&elseblock);
4479 /* Allocate memory to store the data. */
4480 pointer = gfc_conv_descriptor_data_get (se->expr);
4481 STRIP_NOPS (pointer);
4483 /* The allocate_array variants take the old pointer as first argument. */
4484 if (allocatable_array)
4485 tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr);
4487 tmp = gfc_allocate_with_status (&elseblock, size, pstat);
4488 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4491 gfc_add_expr_to_block (&elseblock, tmp);
4493 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4494 var_overflow, integer_zero_node));
4495 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4496 error, gfc_finish_block (&elseblock));
4498 gfc_add_expr_to_block (&se->pre, tmp);
4500 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4502 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4503 && expr->ts.u.derived->attr.alloc_comp)
4505 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4506 ref->u.ar.as->rank);
4507 gfc_add_expr_to_block (&se->pre, tmp);
4514 /* Deallocate an array variable. Also used when an allocated variable goes
4519 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4525 gfc_start_block (&block);
4526 /* Get a pointer to the data. */
4527 var = gfc_conv_descriptor_data_get (descriptor);
4530 /* Parameter is the address of the data component. */
4531 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4532 gfc_add_expr_to_block (&block, tmp);
4534 /* Zero the data pointer. */
4535 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4536 var, build_int_cst (TREE_TYPE (var), 0));
4537 gfc_add_expr_to_block (&block, tmp);
4539 return gfc_finish_block (&block);
4543 /* Create an array constructor from an initialization expression.
4544 We assume the frontend already did any expansions and conversions. */
4547 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4553 unsigned HOST_WIDE_INT lo;
4555 VEC(constructor_elt,gc) *v = NULL;
4557 switch (expr->expr_type)
4560 case EXPR_STRUCTURE:
4561 /* A single scalar or derived type value. Create an array with all
4562 elements equal to that value. */
4563 gfc_init_se (&se, NULL);
4565 if (expr->expr_type == EXPR_CONSTANT)
4566 gfc_conv_constant (&se, expr);
4568 gfc_conv_structure (&se, expr, 1);
4570 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4571 gcc_assert (tmp && INTEGER_CST_P (tmp));
4572 hi = TREE_INT_CST_HIGH (tmp);
4573 lo = TREE_INT_CST_LOW (tmp);
4577 /* This will probably eat buckets of memory for large arrays. */
4578 while (hi != 0 || lo != 0)
4580 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4588 /* Create a vector of all the elements. */
4589 for (c = gfc_constructor_first (expr->value.constructor);
4590 c; c = gfc_constructor_next (c))
4594 /* Problems occur when we get something like
4595 integer :: a(lots) = (/(i, i=1, lots)/) */
4596 gfc_fatal_error ("The number of elements in the array constructor "
4597 "at %L requires an increase of the allowed %d "
4598 "upper limit. See -fmax-array-constructor "
4599 "option", &expr->where,
4600 gfc_option.flag_max_array_constructor);
4603 if (mpz_cmp_si (c->offset, 0) != 0)
4604 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4608 gfc_init_se (&se, NULL);
4609 switch (c->expr->expr_type)
4612 gfc_conv_constant (&se, c->expr);
4613 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4616 case EXPR_STRUCTURE:
4617 gfc_conv_structure (&se, c->expr, 1);
4618 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4623 /* Catch those occasional beasts that do not simplify
4624 for one reason or another, assuming that if they are
4625 standard defying the frontend will catch them. */
4626 gfc_conv_expr (&se, c->expr);
4627 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4634 return gfc_build_null_descriptor (type);
4640 /* Create a constructor from the list of elements. */
4641 tmp = build_constructor (type, v);
4642 TREE_CONSTANT (tmp) = 1;
4647 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4648 returns the size (in elements) of the array. */
4651 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4652 stmtblock_t * pblock)
4667 size = gfc_index_one_node;
4668 offset = gfc_index_zero_node;
4669 for (dim = 0; dim < as->rank; dim++)
4671 /* Evaluate non-constant array bound expressions. */
4672 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4673 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4675 gfc_init_se (&se, NULL);
4676 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4677 gfc_add_block_to_block (pblock, &se.pre);
4678 gfc_add_modify (pblock, lbound, se.expr);
4680 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4681 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4683 gfc_init_se (&se, NULL);
4684 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4685 gfc_add_block_to_block (pblock, &se.pre);
4686 gfc_add_modify (pblock, ubound, se.expr);
4688 /* The offset of this dimension. offset = offset - lbound * stride. */
4689 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4691 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4694 /* The size of this dimension, and the stride of the next. */
4695 if (dim + 1 < as->rank)
4696 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4698 stride = GFC_TYPE_ARRAY_SIZE (type);
4700 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4702 /* Calculate stride = size * (ubound + 1 - lbound). */
4703 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4704 gfc_array_index_type,
4705 gfc_index_one_node, lbound);
4706 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4707 gfc_array_index_type, ubound, tmp);
4708 tmp = fold_build2_loc (input_location, MULT_EXPR,
4709 gfc_array_index_type, size, tmp);
4711 gfc_add_modify (pblock, stride, tmp);
4713 stride = gfc_evaluate_now (tmp, pblock);
4715 /* Make sure that negative size arrays are translated
4716 to being zero size. */
4717 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4718 stride, gfc_index_zero_node);
4719 tmp = fold_build3_loc (input_location, COND_EXPR,
4720 gfc_array_index_type, tmp,
4721 stride, gfc_index_zero_node);
4722 gfc_add_modify (pblock, stride, tmp);
4727 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4729 /* Evaluate non-constant array bound expressions. */
4730 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4731 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4733 gfc_init_se (&se, NULL);
4734 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4735 gfc_add_block_to_block (pblock, &se.pre);
4736 gfc_add_modify (pblock, lbound, se.expr);
4738 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4739 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4741 gfc_init_se (&se, NULL);
4742 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4743 gfc_add_block_to_block (pblock, &se.pre);
4744 gfc_add_modify (pblock, ubound, se.expr);
4747 gfc_trans_vla_type_sizes (sym, pblock);
4754 /* Generate code to initialize/allocate an array variable. */
4757 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4758 gfc_wrapped_block * block)
4762 tree tmp = NULL_TREE;
4769 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4771 /* Do nothing for USEd variables. */
4772 if (sym->attr.use_assoc)
4775 type = TREE_TYPE (decl);
4776 gcc_assert (GFC_ARRAY_TYPE_P (type));
4777 onstack = TREE_CODE (type) != POINTER_TYPE;
4779 gfc_start_block (&init);
4781 /* Evaluate character string length. */
4782 if (sym->ts.type == BT_CHARACTER
4783 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4785 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4787 gfc_trans_vla_type_sizes (sym, &init);
4789 /* Emit a DECL_EXPR for this variable, which will cause the
4790 gimplifier to allocate storage, and all that good stuff. */
4791 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4792 gfc_add_expr_to_block (&init, tmp);
4797 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4801 type = TREE_TYPE (type);
4803 gcc_assert (!sym->attr.use_assoc);
4804 gcc_assert (!TREE_STATIC (decl));
4805 gcc_assert (!sym->module);
4807 if (sym->ts.type == BT_CHARACTER
4808 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4809 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4811 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4813 /* Don't actually allocate space for Cray Pointees. */
4814 if (sym->attr.cray_pointee)
4816 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4817 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4819 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4823 if (gfc_option.flag_stack_arrays)
4825 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
4826 space = build_decl (sym->declared_at.lb->location,
4827 VAR_DECL, create_tmp_var_name ("A"),
4828 TREE_TYPE (TREE_TYPE (decl)));
4829 gfc_trans_vla_type_sizes (sym, &init);
4833 /* The size is the number of elements in the array, so multiply by the
4834 size of an element to get the total size. */
4835 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4836 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4837 size, fold_convert (gfc_array_index_type, tmp));
4839 /* Allocate memory to hold the data. */
4840 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4841 gfc_add_modify (&init, decl, tmp);
4843 /* Free the temporary. */
4844 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4848 /* Set offset of the array. */
4849 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4850 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4852 /* Automatic arrays should not have initializers. */
4853 gcc_assert (!sym->value);
4855 inittree = gfc_finish_block (&init);
4862 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
4863 where also space is located. */
4864 gfc_init_block (&init);
4865 tmp = fold_build1_loc (input_location, DECL_EXPR,
4866 TREE_TYPE (space), space);
4867 gfc_add_expr_to_block (&init, tmp);
4868 addr = fold_build1_loc (sym->declared_at.lb->location,
4869 ADDR_EXPR, TREE_TYPE (decl), space);
4870 gfc_add_modify (&init, decl, addr);
4871 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4874 gfc_add_init_cleanup (block, inittree, tmp);
4878 /* Generate entry and exit code for g77 calling convention arrays. */
4881 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4891 gfc_save_backend_locus (&loc);
4892 gfc_set_backend_locus (&sym->declared_at);
4894 /* Descriptor type. */
4895 parm = sym->backend_decl;
4896 type = TREE_TYPE (parm);
4897 gcc_assert (GFC_ARRAY_TYPE_P (type));
4899 gfc_start_block (&init);
4901 if (sym->ts.type == BT_CHARACTER
4902 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4903 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4905 /* Evaluate the bounds of the array. */
4906 gfc_trans_array_bounds (type, sym, &offset, &init);
4908 /* Set the offset. */
4909 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4910 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4912 /* Set the pointer itself if we aren't using the parameter directly. */
4913 if (TREE_CODE (parm) != PARM_DECL)
4915 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4916 gfc_add_modify (&init, parm, tmp);
4918 stmt = gfc_finish_block (&init);
4920 gfc_restore_backend_locus (&loc);
4922 /* Add the initialization code to the start of the function. */
4924 if (sym->attr.optional || sym->attr.not_always_present)
4926 tmp = gfc_conv_expr_present (sym);
4927 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4930 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4934 /* Modify the descriptor of an array parameter so that it has the
4935 correct lower bound. Also move the upper bound accordingly.
4936 If the array is not packed, it will be copied into a temporary.
4937 For each dimension we set the new lower and upper bounds. Then we copy the
4938 stride and calculate the offset for this dimension. We also work out
4939 what the stride of a packed array would be, and see it the two match.
4940 If the array need repacking, we set the stride to the values we just
4941 calculated, recalculate the offset and copy the array data.
4942 Code is also added to copy the data back at the end of the function.
4946 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4947 gfc_wrapped_block * block)
4954 tree stmtInit, stmtCleanup;
4961 tree stride, stride2;
4971 /* Do nothing for pointer and allocatable arrays. */
4972 if (sym->attr.pointer || sym->attr.allocatable)
4975 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4977 gfc_trans_g77_array (sym, block);
4981 gfc_save_backend_locus (&loc);
4982 gfc_set_backend_locus (&sym->declared_at);
4984 /* Descriptor type. */
4985 type = TREE_TYPE (tmpdesc);
4986 gcc_assert (GFC_ARRAY_TYPE_P (type));
4987 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4988 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4989 gfc_start_block (&init);
4991 if (sym->ts.type == BT_CHARACTER
4992 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4993 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4995 checkparm = (sym->as->type == AS_EXPLICIT
4996 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
4998 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
4999 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5001 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5003 /* For non-constant shape arrays we only check if the first dimension
5004 is contiguous. Repacking higher dimensions wouldn't gain us
5005 anything as we still don't know the array stride. */
5006 partial = gfc_create_var (boolean_type_node, "partial");
5007 TREE_USED (partial) = 1;
5008 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5009 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5010 gfc_index_one_node);
5011 gfc_add_modify (&init, partial, tmp);
5014 partial = NULL_TREE;
5016 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5017 here, however I think it does the right thing. */
5020 /* Set the first stride. */
5021 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5022 stride = gfc_evaluate_now (stride, &init);
5024 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5025 stride, gfc_index_zero_node);
5026 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5027 tmp, gfc_index_one_node, stride);
5028 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5029 gfc_add_modify (&init, stride, tmp);
5031 /* Allow the user to disable array repacking. */
5032 stmt_unpacked = NULL_TREE;
5036 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5037 /* A library call to repack the array if necessary. */
5038 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5039 stmt_unpacked = build_call_expr_loc (input_location,
5040 gfor_fndecl_in_pack, 1, tmp);
5042 stride = gfc_index_one_node;
5044 if (gfc_option.warn_array_temp)
5045 gfc_warning ("Creating array temporary at %L", &loc);
5048 /* This is for the case where the array data is used directly without
5049 calling the repack function. */
5050 if (no_repack || partial != NULL_TREE)
5051 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5053 stmt_packed = NULL_TREE;
5055 /* Assign the data pointer. */
5056 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5058 /* Don't repack unknown shape arrays when the first stride is 1. */
5059 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5060 partial, stmt_packed, stmt_unpacked);
5063 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5064 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5066 offset = gfc_index_zero_node;
5067 size = gfc_index_one_node;
5069 /* Evaluate the bounds of the array. */
5070 for (n = 0; n < sym->as->rank; n++)
5072 if (checkparm || !sym->as->upper[n])
5074 /* Get the bounds of the actual parameter. */
5075 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5076 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5080 dubound = NULL_TREE;
5081 dlbound = NULL_TREE;
5084 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5085 if (!INTEGER_CST_P (lbound))
5087 gfc_init_se (&se, NULL);
5088 gfc_conv_expr_type (&se, sym->as->lower[n],
5089 gfc_array_index_type);
5090 gfc_add_block_to_block (&init, &se.pre);
5091 gfc_add_modify (&init, lbound, se.expr);
5094 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5095 /* Set the desired upper bound. */
5096 if (sym->as->upper[n])
5098 /* We know what we want the upper bound to be. */
5099 if (!INTEGER_CST_P (ubound))
5101 gfc_init_se (&se, NULL);
5102 gfc_conv_expr_type (&se, sym->as->upper[n],
5103 gfc_array_index_type);
5104 gfc_add_block_to_block (&init, &se.pre);
5105 gfc_add_modify (&init, ubound, se.expr);
5108 /* Check the sizes match. */
5111 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5115 temp = fold_build2_loc (input_location, MINUS_EXPR,
5116 gfc_array_index_type, ubound, lbound);
5117 temp = fold_build2_loc (input_location, PLUS_EXPR,
5118 gfc_array_index_type,
5119 gfc_index_one_node, temp);
5120 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5121 gfc_array_index_type, dubound,
5123 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5124 gfc_array_index_type,
5125 gfc_index_one_node, stride2);
5126 tmp = fold_build2_loc (input_location, NE_EXPR,
5127 gfc_array_index_type, temp, stride2);
5128 asprintf (&msg, "Dimension %d of array '%s' has extent "
5129 "%%ld instead of %%ld", n+1, sym->name);
5131 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5132 fold_convert (long_integer_type_node, temp),
5133 fold_convert (long_integer_type_node, stride2));
5140 /* For assumed shape arrays move the upper bound by the same amount
5141 as the lower bound. */
5142 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5143 gfc_array_index_type, dubound, dlbound);
5144 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5145 gfc_array_index_type, tmp, lbound);
5146 gfc_add_modify (&init, ubound, tmp);
5148 /* The offset of this dimension. offset = offset - lbound * stride. */
5149 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5151 offset = fold_build2_loc (input_location, MINUS_EXPR,
5152 gfc_array_index_type, offset, tmp);
5154 /* The size of this dimension, and the stride of the next. */
5155 if (n + 1 < sym->as->rank)
5157 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5159 if (no_repack || partial != NULL_TREE)
5161 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5163 /* Figure out the stride if not a known constant. */
5164 if (!INTEGER_CST_P (stride))
5167 stmt_packed = NULL_TREE;
5170 /* Calculate stride = size * (ubound + 1 - lbound). */
5171 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5172 gfc_array_index_type,
5173 gfc_index_one_node, lbound);
5174 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5175 gfc_array_index_type, ubound, tmp);
5176 size = fold_build2_loc (input_location, MULT_EXPR,
5177 gfc_array_index_type, size, tmp);
5181 /* Assign the stride. */
5182 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5183 tmp = fold_build3_loc (input_location, COND_EXPR,
5184 gfc_array_index_type, partial,
5185 stmt_unpacked, stmt_packed);
5187 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5188 gfc_add_modify (&init, stride, tmp);
5193 stride = GFC_TYPE_ARRAY_SIZE (type);
5195 if (stride && !INTEGER_CST_P (stride))
5197 /* Calculate size = stride * (ubound + 1 - lbound). */
5198 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5199 gfc_array_index_type,
5200 gfc_index_one_node, lbound);
5201 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5202 gfc_array_index_type,
5204 tmp = fold_build2_loc (input_location, MULT_EXPR,
5205 gfc_array_index_type,
5206 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5207 gfc_add_modify (&init, stride, tmp);
5212 /* Set the offset. */
5213 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5214 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5216 gfc_trans_vla_type_sizes (sym, &init);
5218 stmtInit = gfc_finish_block (&init);
5220 /* Only do the entry/initialization code if the arg is present. */
5221 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5222 optional_arg = (sym->attr.optional
5223 || (sym->ns->proc_name->attr.entry_master
5224 && sym->attr.dummy));
5227 tmp = gfc_conv_expr_present (sym);
5228 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5229 build_empty_stmt (input_location));
5234 stmtCleanup = NULL_TREE;
5237 stmtblock_t cleanup;
5238 gfc_start_block (&cleanup);
5240 if (sym->attr.intent != INTENT_IN)
5242 /* Copy the data back. */
5243 tmp = build_call_expr_loc (input_location,
5244 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5245 gfc_add_expr_to_block (&cleanup, tmp);
5248 /* Free the temporary. */
5249 tmp = gfc_call_free (tmpdesc);
5250 gfc_add_expr_to_block (&cleanup, tmp);
5252 stmtCleanup = gfc_finish_block (&cleanup);
5254 /* Only do the cleanup if the array was repacked. */
5255 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5256 tmp = gfc_conv_descriptor_data_get (tmp);
5257 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5259 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5260 build_empty_stmt (input_location));
5264 tmp = gfc_conv_expr_present (sym);
5265 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5266 build_empty_stmt (input_location));
5270 /* We don't need to free any memory allocated by internal_pack as it will
5271 be freed at the end of the function by pop_context. */
5272 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5274 gfc_restore_backend_locus (&loc);
5278 /* Calculate the overall offset, including subreferences. */
5280 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5281 bool subref, gfc_expr *expr)
5291 /* If offset is NULL and this is not a subreferenced array, there is
5293 if (offset == NULL_TREE)
5296 offset = gfc_index_zero_node;
5301 tmp = gfc_conv_array_data (desc);
5302 tmp = build_fold_indirect_ref_loc (input_location,
5304 tmp = gfc_build_array_ref (tmp, offset, NULL);
5306 /* Offset the data pointer for pointer assignments from arrays with
5307 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5310 /* Go past the array reference. */
5311 for (ref = expr->ref; ref; ref = ref->next)
5312 if (ref->type == REF_ARRAY &&
5313 ref->u.ar.type != AR_ELEMENT)
5319 /* Calculate the offset for each subsequent subreference. */
5320 for (; ref; ref = ref->next)
5325 field = ref->u.c.component->backend_decl;
5326 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5327 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5329 tmp, field, NULL_TREE);
5333 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5334 gfc_init_se (&start, NULL);
5335 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5336 gfc_add_block_to_block (block, &start.pre);
5337 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5341 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5342 && ref->u.ar.type == AR_ELEMENT);
5344 /* TODO - Add bounds checking. */
5345 stride = gfc_index_one_node;
5346 index = gfc_index_zero_node;
5347 for (n = 0; n < ref->u.ar.dimen; n++)
5352 /* Update the index. */
5353 gfc_init_se (&start, NULL);
5354 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5355 itmp = gfc_evaluate_now (start.expr, block);
5356 gfc_init_se (&start, NULL);
5357 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5358 jtmp = gfc_evaluate_now (start.expr, block);
5359 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5360 gfc_array_index_type, itmp, jtmp);
5361 itmp = fold_build2_loc (input_location, MULT_EXPR,
5362 gfc_array_index_type, itmp, stride);
5363 index = fold_build2_loc (input_location, PLUS_EXPR,
5364 gfc_array_index_type, itmp, index);
5365 index = gfc_evaluate_now (index, block);
5367 /* Update the stride. */
5368 gfc_init_se (&start, NULL);
5369 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5370 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5371 gfc_array_index_type, start.expr,
5373 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5374 gfc_array_index_type,
5375 gfc_index_one_node, itmp);
5376 stride = fold_build2_loc (input_location, MULT_EXPR,
5377 gfc_array_index_type, stride, itmp);
5378 stride = gfc_evaluate_now (stride, block);
5381 /* Apply the index to obtain the array element. */
5382 tmp = gfc_build_array_ref (tmp, index, NULL);
5392 /* Set the target data pointer. */
5393 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5394 gfc_conv_descriptor_data_set (block, parm, offset);
5398 /* gfc_conv_expr_descriptor needs the string length an expression
5399 so that the size of the temporary can be obtained. This is done
5400 by adding up the string lengths of all the elements in the
5401 expression. Function with non-constant expressions have their
5402 string lengths mapped onto the actual arguments using the
5403 interface mapping machinery in trans-expr.c. */
5405 get_array_charlen (gfc_expr *expr, gfc_se *se)
5407 gfc_interface_mapping mapping;
5408 gfc_formal_arglist *formal;
5409 gfc_actual_arglist *arg;
5412 if (expr->ts.u.cl->length
5413 && gfc_is_constant_expr (expr->ts.u.cl->length))
5415 if (!expr->ts.u.cl->backend_decl)
5416 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5420 switch (expr->expr_type)
5423 get_array_charlen (expr->value.op.op1, se);
5425 /* For parentheses the expression ts.u.cl is identical. */
5426 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5429 expr->ts.u.cl->backend_decl =
5430 gfc_create_var (gfc_charlen_type_node, "sln");
5432 if (expr->value.op.op2)
5434 get_array_charlen (expr->value.op.op2, se);
5436 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5438 /* Add the string lengths and assign them to the expression
5439 string length backend declaration. */
5440 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5441 fold_build2_loc (input_location, PLUS_EXPR,
5442 gfc_charlen_type_node,
5443 expr->value.op.op1->ts.u.cl->backend_decl,
5444 expr->value.op.op2->ts.u.cl->backend_decl));
5447 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5448 expr->value.op.op1->ts.u.cl->backend_decl);
5452 if (expr->value.function.esym == NULL
5453 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5455 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5459 /* Map expressions involving the dummy arguments onto the actual
5460 argument expressions. */
5461 gfc_init_interface_mapping (&mapping);
5462 formal = expr->symtree->n.sym->formal;
5463 arg = expr->value.function.actual;
5465 /* Set se = NULL in the calls to the interface mapping, to suppress any
5467 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5472 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5475 gfc_init_se (&tse, NULL);
5477 /* Build the expression for the character length and convert it. */
5478 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5480 gfc_add_block_to_block (&se->pre, &tse.pre);
5481 gfc_add_block_to_block (&se->post, &tse.post);
5482 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5483 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5484 gfc_charlen_type_node, tse.expr,
5485 build_int_cst (gfc_charlen_type_node, 0));
5486 expr->ts.u.cl->backend_decl = tse.expr;
5487 gfc_free_interface_mapping (&mapping);
5491 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5496 /* Helper function to check dimensions. */
5498 dim_ok (gfc_ss_info *info)
5501 for (n = 0; n < info->dimen; n++)
5502 if (info->dim[n] != n)
5507 /* Convert an array for passing as an actual argument. Expressions and
5508 vector subscripts are evaluated and stored in a temporary, which is then
5509 passed. For whole arrays the descriptor is passed. For array sections
5510 a modified copy of the descriptor is passed, but using the original data.
5512 This function is also used for array pointer assignments, and there
5515 - se->want_pointer && !se->direct_byref
5516 EXPR is an actual argument. On exit, se->expr contains a
5517 pointer to the array descriptor.
5519 - !se->want_pointer && !se->direct_byref
5520 EXPR is an actual argument to an intrinsic function or the
5521 left-hand side of a pointer assignment. On exit, se->expr
5522 contains the descriptor for EXPR.
5524 - !se->want_pointer && se->direct_byref
5525 EXPR is the right-hand side of a pointer assignment and
5526 se->expr is the descriptor for the previously-evaluated
5527 left-hand side. The function creates an assignment from
5531 The se->force_tmp flag disables the non-copying descriptor optimization
5532 that is used for transpose. It may be used in cases where there is an
5533 alias between the transpose argument and another argument in the same
5537 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5549 bool subref_array_target = false;
5552 gcc_assert (ss != NULL);
5553 gcc_assert (ss != gfc_ss_terminator);
5555 /* Special case things we know we can pass easily. */
5556 switch (expr->expr_type)
5559 /* If we have a linear array section, we can pass it directly.
5560 Otherwise we need to copy it into a temporary. */
5562 gcc_assert (ss->type == GFC_SS_SECTION);
5563 gcc_assert (ss->expr == expr);
5564 info = &ss->data.info;
5566 /* Get the descriptor for the array. */
5567 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5568 desc = info->descriptor;
5570 subref_array_target = se->direct_byref && is_subref_array (expr);
5571 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5572 && !subref_array_target;
5579 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5581 /* Create a new descriptor if the array doesn't have one. */
5584 else if (info->ref->u.ar.type == AR_FULL)
5586 else if (se->direct_byref)
5589 full = gfc_full_array_ref_p (info->ref, NULL);
5591 if (full && dim_ok (info))
5593 if (se->direct_byref && !se->byref_noassign)
5595 /* Copy the descriptor for pointer assignments. */
5596 gfc_add_modify (&se->pre, se->expr, desc);
5598 /* Add any offsets from subreferences. */
5599 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5600 subref_array_target, expr);
5602 else if (se->want_pointer)
5604 /* We pass full arrays directly. This means that pointers and
5605 allocatable arrays should also work. */
5606 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5613 if (expr->ts.type == BT_CHARACTER)
5614 se->string_length = gfc_get_expr_charlen (expr);
5622 /* We don't need to copy data in some cases. */
5623 arg = gfc_get_noncopying_intrinsic_argument (expr);
5626 /* This is a call to transpose... */
5627 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5628 /* ... which has already been handled by the scalarizer, so
5629 that we just need to get its argument's descriptor. */
5630 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5634 /* A transformational function return value will be a temporary
5635 array descriptor. We still need to go through the scalarizer
5636 to create the descriptor. Elemental functions ar handled as
5637 arbitrary expressions, i.e. copy to a temporary. */
5639 if (se->direct_byref)
5641 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5643 /* For pointer assignments pass the descriptor directly. */
5647 gcc_assert (se->ss == ss);
5648 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5649 gfc_conv_expr (se, expr);
5653 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5655 if (ss->expr != expr)
5656 /* Elemental function. */
5657 gcc_assert ((expr->value.function.esym != NULL
5658 && expr->value.function.esym->attr.elemental)
5659 || (expr->value.function.isym != NULL
5660 && expr->value.function.isym->elemental));
5662 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5665 if (expr->ts.type == BT_CHARACTER
5666 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5667 get_array_charlen (expr, se);
5673 /* Transformational function. */
5674 info = &ss->data.info;
5680 /* Constant array constructors don't need a temporary. */
5681 if (ss->type == GFC_SS_CONSTRUCTOR
5682 && expr->ts.type != BT_CHARACTER
5683 && gfc_constant_array_constructor_p (expr->value.constructor))
5686 info = &ss->data.info;
5696 /* Something complicated. Copy it into a temporary. */
5702 /* If we are creating a temporary, we don't need to bother about aliases
5707 gfc_init_loopinfo (&loop);
5709 /* Associate the SS with the loop. */
5710 gfc_add_ss_to_loop (&loop, ss);
5712 /* Tell the scalarizer not to bother creating loop variables, etc. */
5714 loop.array_parameter = 1;
5716 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5717 gcc_assert (!se->direct_byref);
5719 /* Setup the scalarizing loops and bounds. */
5720 gfc_conv_ss_startstride (&loop);
5724 /* Tell the scalarizer to make a temporary. */
5725 loop.temp_ss = gfc_get_ss ();
5726 loop.temp_ss->type = GFC_SS_TEMP;
5727 loop.temp_ss->next = gfc_ss_terminator;
5729 if (expr->ts.type == BT_CHARACTER
5730 && !expr->ts.u.cl->backend_decl)
5731 get_array_charlen (expr, se);
5733 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5735 if (expr->ts.type == BT_CHARACTER)
5736 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5738 loop.temp_ss->string_length = NULL;
5740 se->string_length = loop.temp_ss->string_length;
5741 loop.temp_ss->data.temp.dimen = loop.dimen;
5742 loop.temp_ss->data.temp.codimen = loop.codimen;
5743 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5746 gfc_conv_loop_setup (&loop, & expr->where);
5750 /* Copy into a temporary and pass that. We don't need to copy the data
5751 back because expressions and vector subscripts must be INTENT_IN. */
5752 /* TODO: Optimize passing function return values. */
5756 /* Start the copying loops. */
5757 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5758 gfc_mark_ss_chain_used (ss, 1);
5759 gfc_start_scalarized_body (&loop, &block);
5761 /* Copy each data element. */
5762 gfc_init_se (&lse, NULL);
5763 gfc_copy_loopinfo_to_se (&lse, &loop);
5764 gfc_init_se (&rse, NULL);
5765 gfc_copy_loopinfo_to_se (&rse, &loop);
5767 lse.ss = loop.temp_ss;
5770 gfc_conv_scalarized_array_ref (&lse, NULL);
5771 if (expr->ts.type == BT_CHARACTER)
5773 gfc_conv_expr (&rse, expr);
5774 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5775 rse.expr = build_fold_indirect_ref_loc (input_location,
5779 gfc_conv_expr_val (&rse, expr);
5781 gfc_add_block_to_block (&block, &rse.pre);
5782 gfc_add_block_to_block (&block, &lse.pre);
5784 lse.string_length = rse.string_length;
5785 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5786 expr->expr_type == EXPR_VARIABLE, true);
5787 gfc_add_expr_to_block (&block, tmp);
5789 /* Finish the copying loops. */
5790 gfc_trans_scalarizing_loops (&loop, &block);
5792 desc = loop.temp_ss->data.info.descriptor;
5794 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5796 desc = info->descriptor;
5797 se->string_length = ss->string_length;
5801 /* We pass sections without copying to a temporary. Make a new
5802 descriptor and point it at the section we want. The loop variable
5803 limits will be the limits of the section.
5804 A function may decide to repack the array to speed up access, but
5805 we're not bothered about that here. */
5806 int dim, ndim, codim;
5814 /* Set the string_length for a character array. */
5815 if (expr->ts.type == BT_CHARACTER)
5816 se->string_length = gfc_get_expr_charlen (expr);
5818 desc = info->descriptor;
5819 if (se->direct_byref && !se->byref_noassign)
5821 /* For pointer assignments we fill in the destination. */
5823 parmtype = TREE_TYPE (parm);
5827 /* Otherwise make a new one. */
5828 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5829 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5830 loop.codimen, loop.from,
5832 GFC_ARRAY_UNKNOWN, false);
5833 parm = gfc_create_var (parmtype, "parm");
5836 offset = gfc_index_zero_node;
5838 /* The following can be somewhat confusing. We have two
5839 descriptors, a new one and the original array.
5840 {parm, parmtype, dim} refer to the new one.
5841 {desc, type, n, loop} refer to the original, which maybe
5842 a descriptorless array.
5843 The bounds of the scalarization are the bounds of the section.
5844 We don't have to worry about numeric overflows when calculating
5845 the offsets because all elements are within the array data. */
5847 /* Set the dtype. */
5848 tmp = gfc_conv_descriptor_dtype (parm);
5849 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5851 /* Set offset for assignments to pointer only to zero if it is not
5853 if (se->direct_byref
5854 && info->ref && info->ref->u.ar.type != AR_FULL)
5855 base = gfc_index_zero_node;
5856 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5857 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5861 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5862 codim = info->codimen;
5863 for (n = 0; n < ndim; n++)
5865 stride = gfc_conv_array_stride (desc, n);
5867 /* Work out the offset. */
5869 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5871 gcc_assert (info->subscript[n]
5872 && info->subscript[n]->type == GFC_SS_SCALAR);
5873 start = info->subscript[n]->data.scalar.expr;
5877 /* Evaluate and remember the start of the section. */
5878 start = info->start[n];
5879 stride = gfc_evaluate_now (stride, &loop.pre);
5882 tmp = gfc_conv_array_lbound (desc, n);
5883 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5885 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5887 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5891 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5893 /* For elemental dimensions, we only need the offset. */
5897 /* Vector subscripts need copying and are handled elsewhere. */
5899 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5901 /* look for the corresponding scalarizer dimension: dim. */
5902 for (dim = 0; dim < ndim; dim++)
5903 if (info->dim[dim] == n)
5906 /* loop exited early: the DIM being looked for has been found. */
5907 gcc_assert (dim < ndim);
5909 /* Set the new lower bound. */
5910 from = loop.from[dim];
5913 /* If we have an array section or are assigning make sure that
5914 the lower bound is 1. References to the full
5915 array should otherwise keep the original bounds. */
5917 || info->ref->u.ar.type != AR_FULL)
5918 && !integer_onep (from))
5920 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5921 gfc_array_index_type, gfc_index_one_node,
5923 to = fold_build2_loc (input_location, PLUS_EXPR,
5924 gfc_array_index_type, to, tmp);
5925 from = gfc_index_one_node;
5927 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5928 gfc_rank_cst[dim], from);
5930 /* Set the new upper bound. */
5931 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5932 gfc_rank_cst[dim], to);
5934 /* Multiply the stride by the section stride to get the
5936 stride = fold_build2_loc (input_location, MULT_EXPR,
5937 gfc_array_index_type,
5938 stride, info->stride[n]);
5940 if (se->direct_byref
5942 && info->ref->u.ar.type != AR_FULL)
5944 base = fold_build2_loc (input_location, MINUS_EXPR,
5945 TREE_TYPE (base), base, stride);
5947 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5949 tmp = gfc_conv_array_lbound (desc, n);
5950 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5951 TREE_TYPE (base), tmp, loop.from[dim]);
5952 tmp = fold_build2_loc (input_location, MULT_EXPR,
5953 TREE_TYPE (base), tmp,
5954 gfc_conv_array_stride (desc, n));
5955 base = fold_build2_loc (input_location, PLUS_EXPR,
5956 TREE_TYPE (base), tmp, base);
5959 /* Store the new stride. */
5960 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5961 gfc_rank_cst[dim], stride);
5964 for (n = ndim; n < ndim + codim; n++)
5966 /* look for the corresponding scalarizer dimension: dim. */
5967 for (dim = 0; dim < ndim + codim; dim++)
5968 if (info->dim[dim] == n)
5971 /* loop exited early: the DIM being looked for has been found. */
5972 gcc_assert (dim < ndim + codim);
5974 from = loop.from[dim];
5976 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5977 gfc_rank_cst[dim], from);
5978 if (n < ndim + codim - 1)
5979 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5980 gfc_rank_cst[dim], to);
5984 if (se->data_not_needed)
5985 gfc_conv_descriptor_data_set (&loop.pre, parm,
5986 gfc_index_zero_node);
5988 /* Point the data pointer at the 1st element in the section. */
5989 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5990 subref_array_target, expr);
5992 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5993 && !se->data_not_needed)
5995 /* Set the offset. */
5996 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6000 /* Only the callee knows what the correct offset it, so just set
6002 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6007 if (!se->direct_byref || se->byref_noassign)
6009 /* Get a pointer to the new descriptor. */
6010 if (se->want_pointer)
6011 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6016 gfc_add_block_to_block (&se->pre, &loop.pre);
6017 gfc_add_block_to_block (&se->post, &loop.post);
6019 /* Cleanup the scalarizer. */
6020 gfc_cleanup_loop (&loop);
6023 /* Helper function for gfc_conv_array_parameter if array size needs to be
6027 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6030 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6031 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6032 else if (expr->rank > 1)
6033 *size = build_call_expr_loc (input_location,
6034 gfor_fndecl_size0, 1,
6035 gfc_build_addr_expr (NULL, desc));
6038 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6039 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6041 *size = fold_build2_loc (input_location, MINUS_EXPR,
6042 gfc_array_index_type, ubound, lbound);
6043 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6044 *size, gfc_index_one_node);
6045 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6046 *size, gfc_index_zero_node);
6048 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6049 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6050 *size, fold_convert (gfc_array_index_type, elem));
6053 /* Convert an array for passing as an actual parameter. */
6054 /* TODO: Optimize passing g77 arrays. */
6057 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6058 const gfc_symbol *fsym, const char *proc_name,
6063 tree tmp = NULL_TREE;
6065 tree parent = DECL_CONTEXT (current_function_decl);
6066 bool full_array_var;
6067 bool this_array_result;
6070 bool array_constructor;
6071 bool good_allocatable;
6072 bool ultimate_ptr_comp;
6073 bool ultimate_alloc_comp;
6078 ultimate_ptr_comp = false;
6079 ultimate_alloc_comp = false;
6081 for (ref = expr->ref; ref; ref = ref->next)
6083 if (ref->next == NULL)
6086 if (ref->type == REF_COMPONENT)
6088 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6089 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6093 full_array_var = false;
6096 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6097 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6099 sym = full_array_var ? expr->symtree->n.sym : NULL;
6101 /* The symbol should have an array specification. */
6102 gcc_assert (!sym || sym->as || ref->u.ar.as);
6104 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6106 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6107 expr->ts.u.cl->backend_decl = tmp;
6108 se->string_length = tmp;
6111 /* Is this the result of the enclosing procedure? */
6112 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6113 if (this_array_result
6114 && (sym->backend_decl != current_function_decl)
6115 && (sym->backend_decl != parent))
6116 this_array_result = false;
6118 /* Passing address of the array if it is not pointer or assumed-shape. */
6119 if (full_array_var && g77 && !this_array_result)
6121 tmp = gfc_get_symbol_decl (sym);
6123 if (sym->ts.type == BT_CHARACTER)
6124 se->string_length = sym->ts.u.cl->backend_decl;
6126 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6128 gfc_conv_expr_descriptor (se, expr, ss);
6129 se->expr = gfc_conv_array_data (se->expr);
6133 if (!sym->attr.pointer
6135 && sym->as->type != AS_ASSUMED_SHAPE
6136 && !sym->attr.allocatable)
6138 /* Some variables are declared directly, others are declared as
6139 pointers and allocated on the heap. */
6140 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6143 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6145 array_parameter_size (tmp, expr, size);
6149 if (sym->attr.allocatable)
6151 if (sym->attr.dummy || sym->attr.result)
6153 gfc_conv_expr_descriptor (se, expr, ss);
6157 array_parameter_size (tmp, expr, size);
6158 se->expr = gfc_conv_array_data (tmp);
6163 /* A convenient reduction in scope. */
6164 contiguous = g77 && !this_array_result && contiguous;
6166 /* There is no need to pack and unpack the array, if it is contiguous
6167 and not a deferred- or assumed-shape array, or if it is simply
6169 no_pack = ((sym && sym->as
6170 && !sym->attr.pointer
6171 && sym->as->type != AS_DEFERRED
6172 && sym->as->type != AS_ASSUMED_SHAPE)
6174 (ref && ref->u.ar.as
6175 && ref->u.ar.as->type != AS_DEFERRED
6176 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6178 gfc_is_simply_contiguous (expr, false));
6180 no_pack = contiguous && no_pack;
6182 /* Array constructors are always contiguous and do not need packing. */
6183 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6185 /* Same is true of contiguous sections from allocatable variables. */
6186 good_allocatable = contiguous
6188 && expr->symtree->n.sym->attr.allocatable;
6190 /* Or ultimate allocatable components. */
6191 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6193 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6195 gfc_conv_expr_descriptor (se, expr, ss);
6196 if (expr->ts.type == BT_CHARACTER)
6197 se->string_length = expr->ts.u.cl->backend_decl;
6199 array_parameter_size (se->expr, expr, size);
6200 se->expr = gfc_conv_array_data (se->expr);
6204 if (this_array_result)
6206 /* Result of the enclosing function. */
6207 gfc_conv_expr_descriptor (se, expr, ss);
6209 array_parameter_size (se->expr, expr, size);
6210 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6212 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6213 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6214 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6221 /* Every other type of array. */
6222 se->want_pointer = 1;
6223 gfc_conv_expr_descriptor (se, expr, ss);
6225 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6230 /* Deallocate the allocatable components of structures that are
6232 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6233 && expr->ts.u.derived->attr.alloc_comp
6234 && expr->expr_type != EXPR_VARIABLE)
6236 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6237 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6239 /* The components shall be deallocated before their containing entity. */
6240 gfc_prepend_expr_to_block (&se->post, tmp);
6243 if (g77 || (fsym && fsym->attr.contiguous
6244 && !gfc_is_simply_contiguous (expr, false)))
6246 tree origptr = NULL_TREE;
6250 /* For contiguous arrays, save the original value of the descriptor. */
6253 origptr = gfc_create_var (pvoid_type_node, "origptr");
6254 tmp = build_fold_indirect_ref_loc (input_location, desc);
6255 tmp = gfc_conv_array_data (tmp);
6256 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6257 TREE_TYPE (origptr), origptr,
6258 fold_convert (TREE_TYPE (origptr), tmp));
6259 gfc_add_expr_to_block (&se->pre, tmp);
6262 /* Repack the array. */
6263 if (gfc_option.warn_array_temp)
6266 gfc_warning ("Creating array temporary at %L for argument '%s'",
6267 &expr->where, fsym->name);
6269 gfc_warning ("Creating array temporary at %L", &expr->where);
6272 ptr = build_call_expr_loc (input_location,
6273 gfor_fndecl_in_pack, 1, desc);
6275 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6277 tmp = gfc_conv_expr_present (sym);
6278 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6279 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6280 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6283 ptr = gfc_evaluate_now (ptr, &se->pre);
6285 /* Use the packed data for the actual argument, except for contiguous arrays,
6286 where the descriptor's data component is set. */
6291 tmp = build_fold_indirect_ref_loc (input_location, desc);
6292 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6295 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6299 if (fsym && proc_name)
6300 asprintf (&msg, "An array temporary was created for argument "
6301 "'%s' of procedure '%s'", fsym->name, proc_name);
6303 asprintf (&msg, "An array temporary was created");
6305 tmp = build_fold_indirect_ref_loc (input_location,
6307 tmp = gfc_conv_array_data (tmp);
6308 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6309 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6311 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6312 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6314 gfc_conv_expr_present (sym), tmp);
6316 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6321 gfc_start_block (&block);
6323 /* Copy the data back. */
6324 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6326 tmp = build_call_expr_loc (input_location,
6327 gfor_fndecl_in_unpack, 2, desc, ptr);
6328 gfc_add_expr_to_block (&block, tmp);
6331 /* Free the temporary. */
6332 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6333 gfc_add_expr_to_block (&block, tmp);
6335 stmt = gfc_finish_block (&block);
6337 gfc_init_block (&block);
6338 /* Only if it was repacked. This code needs to be executed before the
6339 loop cleanup code. */
6340 tmp = build_fold_indirect_ref_loc (input_location,
6342 tmp = gfc_conv_array_data (tmp);
6343 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6344 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6346 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6347 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6349 gfc_conv_expr_present (sym), tmp);
6351 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6353 gfc_add_expr_to_block (&block, tmp);
6354 gfc_add_block_to_block (&block, &se->post);
6356 gfc_init_block (&se->post);
6358 /* Reset the descriptor pointer. */
6361 tmp = build_fold_indirect_ref_loc (input_location, desc);
6362 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6365 gfc_add_block_to_block (&se->post, &block);
6370 /* Generate code to deallocate an array, if it is allocated. */
6373 gfc_trans_dealloc_allocated (tree descriptor)
6379 gfc_start_block (&block);
6381 var = gfc_conv_descriptor_data_get (descriptor);
6384 /* Call array_deallocate with an int * present in the second argument.
6385 Although it is ignored here, it's presence ensures that arrays that
6386 are already deallocated are ignored. */
6387 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6388 gfc_add_expr_to_block (&block, tmp);
6390 /* Zero the data pointer. */
6391 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6392 var, build_int_cst (TREE_TYPE (var), 0));
6393 gfc_add_expr_to_block (&block, tmp);
6395 return gfc_finish_block (&block);
6399 /* This helper function calculates the size in words of a full array. */
6402 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6407 idx = gfc_rank_cst[rank - 1];
6408 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6409 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6410 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6412 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6413 tmp, gfc_index_one_node);
6414 tmp = gfc_evaluate_now (tmp, block);
6416 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6417 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6419 return gfc_evaluate_now (tmp, block);
6423 /* Allocate dest to the same size as src, and copy src -> dest.
6424 If no_malloc is set, only the copy is done. */
6427 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6437 /* If the source is null, set the destination to null. Then,
6438 allocate memory to the destination. */
6439 gfc_init_block (&block);
6443 tmp = null_pointer_node;
6444 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6445 gfc_add_expr_to_block (&block, tmp);
6446 null_data = gfc_finish_block (&block);
6448 gfc_init_block (&block);
6449 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6452 tmp = gfc_call_malloc (&block, type, size);
6453 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6454 dest, fold_convert (type, tmp));
6455 gfc_add_expr_to_block (&block, tmp);
6458 tmp = built_in_decls[BUILT_IN_MEMCPY];
6459 tmp = build_call_expr_loc (input_location, tmp, 3,
6464 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6465 null_data = gfc_finish_block (&block);
6467 gfc_init_block (&block);
6468 nelems = get_full_array_size (&block, src, rank);
6469 tmp = fold_convert (gfc_array_index_type,
6470 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6471 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6475 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6476 tmp = gfc_call_malloc (&block, tmp, size);
6477 gfc_conv_descriptor_data_set (&block, dest, tmp);
6480 /* We know the temporary and the value will be the same length,
6481 so can use memcpy. */
6482 tmp = built_in_decls[BUILT_IN_MEMCPY];
6483 tmp = build_call_expr_loc (input_location,
6484 tmp, 3, gfc_conv_descriptor_data_get (dest),
6485 gfc_conv_descriptor_data_get (src), size);
6488 gfc_add_expr_to_block (&block, tmp);
6489 tmp = gfc_finish_block (&block);
6491 /* Null the destination if the source is null; otherwise do
6492 the allocate and copy. */
6496 null_cond = gfc_conv_descriptor_data_get (src);
6498 null_cond = convert (pvoid_type_node, null_cond);
6499 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6500 null_cond, null_pointer_node);
6501 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6505 /* Allocate dest to the same size as src, and copy data src -> dest. */
6508 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6510 return duplicate_allocatable (dest, src, type, rank, false);
6514 /* Copy data src -> dest. */
6517 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6519 return duplicate_allocatable (dest, src, type, rank, true);
6523 /* Recursively traverse an object of derived type, generating code to
6524 deallocate, nullify or copy allocatable components. This is the work horse
6525 function for the functions named in this enum. */
6527 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6528 COPY_ONLY_ALLOC_COMP};
6531 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6532 tree dest, int rank, int purpose)
6536 stmtblock_t fnblock;
6537 stmtblock_t loopbody;
6548 tree null_cond = NULL_TREE;
6550 gfc_init_block (&fnblock);
6552 decl_type = TREE_TYPE (decl);
6554 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6555 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6557 decl = build_fold_indirect_ref_loc (input_location,
6560 /* Just in case in gets dereferenced. */
6561 decl_type = TREE_TYPE (decl);
6563 /* If this an array of derived types with allocatable components
6564 build a loop and recursively call this function. */
6565 if (TREE_CODE (decl_type) == ARRAY_TYPE
6566 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6568 tmp = gfc_conv_array_data (decl);
6569 var = build_fold_indirect_ref_loc (input_location,
6572 /* Get the number of elements - 1 and set the counter. */
6573 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6575 /* Use the descriptor for an allocatable array. Since this
6576 is a full array reference, we only need the descriptor
6577 information from dimension = rank. */
6578 tmp = get_full_array_size (&fnblock, decl, rank);
6579 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6580 gfc_array_index_type, tmp,
6581 gfc_index_one_node);
6583 null_cond = gfc_conv_descriptor_data_get (decl);
6584 null_cond = fold_build2_loc (input_location, NE_EXPR,
6585 boolean_type_node, null_cond,
6586 build_int_cst (TREE_TYPE (null_cond), 0));
6590 /* Otherwise use the TYPE_DOMAIN information. */
6591 tmp = array_type_nelts (decl_type);
6592 tmp = fold_convert (gfc_array_index_type, tmp);
6595 /* Remember that this is, in fact, the no. of elements - 1. */
6596 nelems = gfc_evaluate_now (tmp, &fnblock);
6597 index = gfc_create_var (gfc_array_index_type, "S");
6599 /* Build the body of the loop. */
6600 gfc_init_block (&loopbody);
6602 vref = gfc_build_array_ref (var, index, NULL);
6604 if (purpose == COPY_ALLOC_COMP)
6606 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6608 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6609 gfc_add_expr_to_block (&fnblock, tmp);
6611 tmp = build_fold_indirect_ref_loc (input_location,
6612 gfc_conv_array_data (dest));
6613 dref = gfc_build_array_ref (tmp, index, NULL);
6614 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6616 else if (purpose == COPY_ONLY_ALLOC_COMP)
6618 tmp = build_fold_indirect_ref_loc (input_location,
6619 gfc_conv_array_data (dest));
6620 dref = gfc_build_array_ref (tmp, index, NULL);
6621 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6625 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6627 gfc_add_expr_to_block (&loopbody, tmp);
6629 /* Build the loop and return. */
6630 gfc_init_loopinfo (&loop);
6632 loop.from[0] = gfc_index_zero_node;
6633 loop.loopvar[0] = index;
6634 loop.to[0] = nelems;
6635 gfc_trans_scalarizing_loops (&loop, &loopbody);
6636 gfc_add_block_to_block (&fnblock, &loop.pre);
6638 tmp = gfc_finish_block (&fnblock);
6639 if (null_cond != NULL_TREE)
6640 tmp = build3_v (COND_EXPR, null_cond, tmp,
6641 build_empty_stmt (input_location));
6646 /* Otherwise, act on the components or recursively call self to
6647 act on a chain of components. */
6648 for (c = der_type->components; c; c = c->next)
6650 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6651 || c->ts.type == BT_CLASS)
6652 && c->ts.u.derived->attr.alloc_comp;
6653 cdecl = c->backend_decl;
6654 ctype = TREE_TYPE (cdecl);
6658 case DEALLOCATE_ALLOC_COMP:
6659 if (c->attr.allocatable && c->attr.dimension)
6661 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6662 decl, cdecl, NULL_TREE);
6663 if (cmp_has_alloc_comps && !c->attr.pointer)
6665 /* Do not deallocate the components of ultimate pointer
6667 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6668 c->as->rank, purpose);
6669 gfc_add_expr_to_block (&fnblock, tmp);
6671 tmp = gfc_trans_dealloc_allocated (comp);
6672 gfc_add_expr_to_block (&fnblock, tmp);
6674 else if (c->attr.allocatable)
6676 /* Allocatable scalar components. */
6677 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6678 decl, cdecl, NULL_TREE);
6680 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6682 gfc_add_expr_to_block (&fnblock, tmp);
6684 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6685 void_type_node, comp,
6686 build_int_cst (TREE_TYPE (comp), 0));
6687 gfc_add_expr_to_block (&fnblock, tmp);
6689 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6691 /* Allocatable scalar CLASS components. */
6692 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6693 decl, cdecl, NULL_TREE);
6695 /* Add reference to '_data' component. */
6696 tmp = CLASS_DATA (c)->backend_decl;
6697 comp = fold_build3_loc (input_location, COMPONENT_REF,
6698 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6700 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6701 CLASS_DATA (c)->ts);
6702 gfc_add_expr_to_block (&fnblock, tmp);
6704 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6705 void_type_node, comp,
6706 build_int_cst (TREE_TYPE (comp), 0));
6707 gfc_add_expr_to_block (&fnblock, tmp);
6711 case NULLIFY_ALLOC_COMP:
6712 if (c->attr.pointer)
6714 else if (c->attr.allocatable && c->attr.dimension)
6716 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6717 decl, cdecl, NULL_TREE);
6718 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6720 else if (c->attr.allocatable)
6722 /* Allocatable scalar components. */
6723 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6724 decl, cdecl, NULL_TREE);
6725 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6726 void_type_node, comp,
6727 build_int_cst (TREE_TYPE (comp), 0));
6728 gfc_add_expr_to_block (&fnblock, tmp);
6730 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6732 /* Allocatable scalar CLASS components. */
6733 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6734 decl, cdecl, NULL_TREE);
6735 /* Add reference to '_data' component. */
6736 tmp = CLASS_DATA (c)->backend_decl;
6737 comp = fold_build3_loc (input_location, COMPONENT_REF,
6738 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6739 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6740 void_type_node, comp,
6741 build_int_cst (TREE_TYPE (comp), 0));
6742 gfc_add_expr_to_block (&fnblock, tmp);
6744 else if (cmp_has_alloc_comps)
6746 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6747 decl, cdecl, NULL_TREE);
6748 rank = c->as ? c->as->rank : 0;
6749 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6751 gfc_add_expr_to_block (&fnblock, tmp);
6755 case COPY_ALLOC_COMP:
6756 if (c->attr.pointer)
6759 /* We need source and destination components. */
6760 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6762 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6764 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6766 if (c->attr.allocatable && !cmp_has_alloc_comps)
6768 rank = c->as ? c->as->rank : 0;
6769 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6770 gfc_add_expr_to_block (&fnblock, tmp);
6773 if (cmp_has_alloc_comps)
6775 rank = c->as ? c->as->rank : 0;
6776 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6777 gfc_add_modify (&fnblock, dcmp, tmp);
6778 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6780 gfc_add_expr_to_block (&fnblock, tmp);
6790 return gfc_finish_block (&fnblock);
6793 /* Recursively traverse an object of derived type, generating code to
6794 nullify allocatable components. */
6797 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6799 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6800 NULLIFY_ALLOC_COMP);
6804 /* Recursively traverse an object of derived type, generating code to
6805 deallocate allocatable components. */
6808 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6810 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6811 DEALLOCATE_ALLOC_COMP);
6815 /* Recursively traverse an object of derived type, generating code to
6816 copy it and its allocatable components. */
6819 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6821 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6825 /* Recursively traverse an object of derived type, generating code to
6826 copy only its allocatable components. */
6829 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6831 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6835 /* Returns the value of LBOUND for an expression. This could be broken out
6836 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6837 called by gfc_alloc_allocatable_for_assignment. */
6839 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6844 tree cond, cond1, cond3, cond4;
6848 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6850 tmp = gfc_rank_cst[dim];
6851 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6852 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6853 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6854 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6856 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6857 stride, gfc_index_zero_node);
6858 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6859 boolean_type_node, cond3, cond1);
6860 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6861 stride, gfc_index_zero_node);
6863 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6864 tmp, build_int_cst (gfc_array_index_type,
6867 cond = boolean_false_node;
6869 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6870 boolean_type_node, cond3, cond4);
6871 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6872 boolean_type_node, cond, cond1);
6874 return fold_build3_loc (input_location, COND_EXPR,
6875 gfc_array_index_type, cond,
6876 lbound, gfc_index_one_node);
6878 else if (expr->expr_type == EXPR_VARIABLE)
6880 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6881 for (ref = expr->ref; ref; ref = ref->next)
6883 if (ref->type == REF_COMPONENT
6884 && ref->u.c.component->as
6886 && ref->next->u.ar.type == AR_FULL)
6887 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
6889 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
6891 else if (expr->expr_type == EXPR_FUNCTION)
6893 /* A conversion function, so use the argument. */
6894 expr = expr->value.function.actual->expr;
6895 if (expr->expr_type != EXPR_VARIABLE)
6896 return gfc_index_one_node;
6897 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6898 return get_std_lbound (expr, desc, dim, assumed_size);
6901 return gfc_index_one_node;
6905 /* Returns true if an expression represents an lhs that can be reallocated
6909 gfc_is_reallocatable_lhs (gfc_expr *expr)
6916 /* An allocatable variable. */
6917 if (expr->symtree->n.sym->attr.allocatable
6919 && expr->ref->type == REF_ARRAY
6920 && expr->ref->u.ar.type == AR_FULL)
6923 /* All that can be left are allocatable components. */
6924 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6925 && expr->symtree->n.sym->ts.type != BT_CLASS)
6926 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6929 /* Find a component ref followed by an array reference. */
6930 for (ref = expr->ref; ref; ref = ref->next)
6932 && ref->type == REF_COMPONENT
6933 && ref->next->type == REF_ARRAY
6934 && !ref->next->next)
6940 /* Return true if valid reallocatable lhs. */
6941 if (ref->u.c.component->attr.allocatable
6942 && ref->next->u.ar.type == AR_FULL)
6949 /* Allocate the lhs of an assignment to an allocatable array, otherwise
6953 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
6957 stmtblock_t realloc_block;
6958 stmtblock_t alloc_block;
6981 gfc_array_spec * as;
6983 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
6984 Find the lhs expression in the loop chain and set expr1 and
6985 expr2 accordingly. */
6986 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
6989 /* Find the ss for the lhs. */
6991 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6992 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
6994 if (lss == gfc_ss_terminator)
6999 /* Bail out if this is not a valid allocate on assignment. */
7000 if (!gfc_is_reallocatable_lhs (expr1)
7001 || (expr2 && !expr2->rank))
7004 /* Find the ss for the lhs. */
7006 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7007 if (lss->expr == expr1)
7010 if (lss == gfc_ss_terminator)
7013 /* Find an ss for the rhs. For operator expressions, we see the
7014 ss's for the operands. Any one of these will do. */
7016 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7017 if (rss->expr != expr1 && rss != loop->temp_ss)
7020 if (expr2 && rss == gfc_ss_terminator)
7023 gfc_start_block (&fblock);
7025 /* Since the lhs is allocatable, this must be a descriptor type.
7026 Get the data and array size. */
7027 desc = lss->data.info.descriptor;
7028 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7029 array1 = gfc_conv_descriptor_data_get (desc);
7031 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7032 deallocated if expr is an array of different shape or any of the
7033 corresponding length type parameter values of variable and expr
7034 differ." This assures F95 compatibility. */
7035 jump_label1 = gfc_build_label_decl (NULL_TREE);
7036 jump_label2 = gfc_build_label_decl (NULL_TREE);
7038 /* Allocate if data is NULL. */
7039 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7040 array1, build_int_cst (TREE_TYPE (array1), 0));
7041 tmp = build3_v (COND_EXPR, cond,
7042 build1_v (GOTO_EXPR, jump_label1),
7043 build_empty_stmt (input_location));
7044 gfc_add_expr_to_block (&fblock, tmp);
7046 /* Get arrayspec if expr is a full array. */
7047 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7048 && expr2->value.function.isym
7049 && expr2->value.function.isym->conversion)
7051 /* For conversion functions, take the arg. */
7052 gfc_expr *arg = expr2->value.function.actual->expr;
7053 as = gfc_get_full_arrayspec_from_expr (arg);
7056 as = gfc_get_full_arrayspec_from_expr (expr2);
7060 /* If the lhs shape is not the same as the rhs jump to setting the
7061 bounds and doing the reallocation....... */
7062 for (n = 0; n < expr1->rank; n++)
7064 /* Check the shape. */
7065 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7066 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7067 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7068 gfc_array_index_type,
7069 loop->to[n], loop->from[n]);
7070 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7071 gfc_array_index_type,
7073 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7074 gfc_array_index_type,
7076 cond = fold_build2_loc (input_location, NE_EXPR,
7078 tmp, gfc_index_zero_node);
7079 tmp = build3_v (COND_EXPR, cond,
7080 build1_v (GOTO_EXPR, jump_label1),
7081 build_empty_stmt (input_location));
7082 gfc_add_expr_to_block (&fblock, tmp);
7085 /* ....else jump past the (re)alloc code. */
7086 tmp = build1_v (GOTO_EXPR, jump_label2);
7087 gfc_add_expr_to_block (&fblock, tmp);
7089 /* Add the label to start automatic (re)allocation. */
7090 tmp = build1_v (LABEL_EXPR, jump_label1);
7091 gfc_add_expr_to_block (&fblock, tmp);
7093 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7095 /* Get the rhs size. Fix both sizes. */
7097 desc2 = rss->data.info.descriptor;
7100 size2 = gfc_index_one_node;
7101 for (n = 0; n < expr2->rank; n++)
7103 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7104 gfc_array_index_type,
7105 loop->to[n], loop->from[n]);
7106 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7107 gfc_array_index_type,
7108 tmp, gfc_index_one_node);
7109 size2 = fold_build2_loc (input_location, MULT_EXPR,
7110 gfc_array_index_type,
7114 size1 = gfc_evaluate_now (size1, &fblock);
7115 size2 = gfc_evaluate_now (size2, &fblock);
7117 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7119 neq_size = gfc_evaluate_now (cond, &fblock);
7122 /* Now modify the lhs descriptor and the associated scalarizer
7123 variables. F2003 7.4.1.3: "If variable is or becomes an
7124 unallocated allocatable variable, then it is allocated with each
7125 deferred type parameter equal to the corresponding type parameters
7126 of expr , with the shape of expr , and with each lower bound equal
7127 to the corresponding element of LBOUND(expr)."
7128 Reuse size1 to keep a dimension-by-dimension track of the
7129 stride of the new array. */
7130 size1 = gfc_index_one_node;
7131 offset = gfc_index_zero_node;
7133 for (n = 0; n < expr2->rank; n++)
7135 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7136 gfc_array_index_type,
7137 loop->to[n], loop->from[n]);
7138 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7139 gfc_array_index_type,
7140 tmp, gfc_index_one_node);
7142 lbound = gfc_index_one_node;
7147 lbd = get_std_lbound (expr2, desc2, n,
7148 as->type == AS_ASSUMED_SIZE);
7149 ubound = fold_build2_loc (input_location,
7151 gfc_array_index_type,
7153 ubound = fold_build2_loc (input_location,
7155 gfc_array_index_type,
7160 gfc_conv_descriptor_lbound_set (&fblock, desc,
7163 gfc_conv_descriptor_ubound_set (&fblock, desc,
7166 gfc_conv_descriptor_stride_set (&fblock, desc,
7169 lbound = gfc_conv_descriptor_lbound_get (desc,
7171 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7172 gfc_array_index_type,
7174 offset = fold_build2_loc (input_location, MINUS_EXPR,
7175 gfc_array_index_type,
7177 size1 = fold_build2_loc (input_location, MULT_EXPR,
7178 gfc_array_index_type,
7182 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7183 the array offset is saved and the info.offset is used for a
7184 running offset. Use the saved_offset instead. */
7185 tmp = gfc_conv_descriptor_offset (desc);
7186 gfc_add_modify (&fblock, tmp, offset);
7187 if (lss->data.info.saved_offset
7188 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7189 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7191 /* Now set the deltas for the lhs. */
7192 for (n = 0; n < expr1->rank; n++)
7194 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7195 dim = lss->data.info.dim[n];
7196 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7197 gfc_array_index_type, tmp,
7199 if (lss->data.info.delta[dim]
7200 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7201 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7204 /* Get the new lhs size in bytes. */
7205 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7207 tmp = expr2->ts.u.cl->backend_decl;
7208 gcc_assert (expr1->ts.u.cl->backend_decl);
7209 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7210 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7212 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7214 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7215 tmp = fold_build2_loc (input_location, MULT_EXPR,
7216 gfc_array_index_type, tmp,
7217 expr1->ts.u.cl->backend_decl);
7220 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7221 tmp = fold_convert (gfc_array_index_type, tmp);
7222 size2 = fold_build2_loc (input_location, MULT_EXPR,
7223 gfc_array_index_type,
7225 size2 = fold_convert (size_type_node, size2);
7226 size2 = gfc_evaluate_now (size2, &fblock);
7228 /* Realloc expression. Note that the scalarizer uses desc.data
7229 in the array reference - (*desc.data)[<element>]. */
7230 gfc_init_block (&realloc_block);
7231 tmp = build_call_expr_loc (input_location,
7232 built_in_decls[BUILT_IN_REALLOC], 2,
7233 fold_convert (pvoid_type_node, array1),
7235 gfc_conv_descriptor_data_set (&realloc_block,
7237 realloc_expr = gfc_finish_block (&realloc_block);
7239 /* Only reallocate if sizes are different. */
7240 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7241 build_empty_stmt (input_location));
7245 /* Malloc expression. */
7246 gfc_init_block (&alloc_block);
7247 tmp = build_call_expr_loc (input_location,
7248 built_in_decls[BUILT_IN_MALLOC], 1,
7250 gfc_conv_descriptor_data_set (&alloc_block,
7252 tmp = gfc_conv_descriptor_dtype (desc);
7253 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7254 alloc_expr = gfc_finish_block (&alloc_block);
7256 /* Malloc if not allocated; realloc otherwise. */
7257 tmp = build_int_cst (TREE_TYPE (array1), 0);
7258 cond = fold_build2_loc (input_location, EQ_EXPR,
7261 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7262 gfc_add_expr_to_block (&fblock, tmp);
7264 /* Make sure that the scalarizer data pointer is updated. */
7265 if (lss->data.info.data
7266 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7268 tmp = gfc_conv_descriptor_data_get (desc);
7269 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7272 /* Add the exit label. */
7273 tmp = build1_v (LABEL_EXPR, jump_label2);
7274 gfc_add_expr_to_block (&fblock, tmp);
7276 return gfc_finish_block (&fblock);
7280 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7281 Do likewise, recursively if necessary, with the allocatable components of
7285 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7291 stmtblock_t cleanup;
7294 bool sym_has_alloc_comp;
7296 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7297 || sym->ts.type == BT_CLASS)
7298 && sym->ts.u.derived->attr.alloc_comp;
7300 /* Make sure the frontend gets these right. */
7301 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7302 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7303 "allocatable attribute or derived type without allocatable "
7306 gfc_save_backend_locus (&loc);
7307 gfc_set_backend_locus (&sym->declared_at);
7308 gfc_init_block (&init);
7310 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7311 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7313 if (sym->ts.type == BT_CHARACTER
7314 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7316 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7317 gfc_trans_vla_type_sizes (sym, &init);
7320 /* Dummy, use associated and result variables don't need anything special. */
7321 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7323 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7324 gfc_restore_backend_locus (&loc);
7328 descriptor = sym->backend_decl;
7330 /* Although static, derived types with default initializers and
7331 allocatable components must not be nulled wholesale; instead they
7332 are treated component by component. */
7333 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7335 /* SAVEd variables are not freed on exit. */
7336 gfc_trans_static_array_pointer (sym);
7338 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7339 gfc_restore_backend_locus (&loc);
7343 /* Get the descriptor type. */
7344 type = TREE_TYPE (sym->backend_decl);
7346 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7349 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7351 if (sym->value == NULL
7352 || !gfc_has_default_initializer (sym->ts.u.derived))
7354 rank = sym->as ? sym->as->rank : 0;
7355 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7357 gfc_add_expr_to_block (&init, tmp);
7360 gfc_init_default_dt (sym, &init, false);
7363 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7365 /* If the backend_decl is not a descriptor, we must have a pointer
7367 descriptor = build_fold_indirect_ref_loc (input_location,
7369 type = TREE_TYPE (descriptor);
7372 /* NULLIFY the data pointer. */
7373 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7374 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7376 gfc_restore_backend_locus (&loc);
7377 gfc_init_block (&cleanup);
7379 /* Allocatable arrays need to be freed when they go out of scope.
7380 The allocatable components of pointers must not be touched. */
7381 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7382 && !sym->attr.pointer && !sym->attr.save)
7385 rank = sym->as ? sym->as->rank : 0;
7386 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7387 gfc_add_expr_to_block (&cleanup, tmp);
7390 if (sym->attr.allocatable && sym->attr.dimension
7391 && !sym->attr.save && !sym->attr.result)
7393 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7394 gfc_add_expr_to_block (&cleanup, tmp);
7397 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7398 gfc_finish_block (&cleanup));
7401 /************ Expression Walking Functions ******************/
7403 /* Walk a variable reference.
7405 Possible extension - multiple component subscripts.
7406 x(:,:) = foo%a(:)%b(:)
7408 forall (i=..., j=...)
7409 x(i,j) = foo%a(j)%b(i)
7411 This adds a fair amount of complexity because you need to deal with more
7412 than one ref. Maybe handle in a similar manner to vector subscripts.
7413 Maybe not worth the effort. */
7417 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7424 for (ref = expr->ref; ref; ref = ref->next)
7425 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7428 for (; ref; ref = ref->next)
7430 if (ref->type == REF_SUBSTRING)
7432 newss = gfc_get_ss ();
7433 newss->type = GFC_SS_SCALAR;
7434 newss->expr = ref->u.ss.start;
7438 newss = gfc_get_ss ();
7439 newss->type = GFC_SS_SCALAR;
7440 newss->expr = ref->u.ss.end;
7445 /* We're only interested in array sections from now on. */
7446 if (ref->type != REF_ARRAY)
7451 if (ar->as->rank == 0 && ref->next != NULL)
7453 /* Scalar coarray. */
7460 for (n = 0; n < ar->dimen + ar->codimen; n++)
7462 newss = gfc_get_ss ();
7463 newss->type = GFC_SS_SCALAR;
7464 newss->expr = ar->start[n];
7471 newss = gfc_get_ss ();
7472 newss->type = GFC_SS_SECTION;
7475 newss->data.info.dimen = ar->as->rank;
7476 newss->data.info.codimen = 0;
7477 newss->data.info.ref = ref;
7479 /* Make sure array is the same as array(:,:), this way
7480 we don't need to special case all the time. */
7481 ar->dimen = ar->as->rank;
7483 for (n = 0; n < ar->dimen; n++)
7485 newss->data.info.dim[n] = n;
7486 ar->dimen_type[n] = DIMEN_RANGE;
7488 gcc_assert (ar->start[n] == NULL);
7489 gcc_assert (ar->end[n] == NULL);
7490 gcc_assert (ar->stride[n] == NULL);
7492 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7494 newss->data.info.dim[n] = n;
7495 ar->dimen_type[n] = DIMEN_RANGE;
7497 gcc_assert (ar->start[n] == NULL);
7498 gcc_assert (ar->end[n] == NULL);
7504 newss = gfc_get_ss ();
7505 newss->type = GFC_SS_SECTION;
7508 newss->data.info.dimen = 0;
7509 newss->data.info.codimen = 0;
7510 newss->data.info.ref = ref;
7512 /* We add SS chains for all the subscripts in the section. */
7513 for (n = 0; n < ar->dimen + ar->codimen; n++)
7517 switch (ar->dimen_type[n])
7519 case DIMEN_THIS_IMAGE:
7522 /* Add SS for elemental (scalar) subscripts. */
7523 gcc_assert (ar->start[n]);
7524 indexss = gfc_get_ss ();
7525 indexss->type = GFC_SS_SCALAR;
7526 indexss->expr = ar->start[n];
7527 indexss->next = gfc_ss_terminator;
7528 indexss->loop_chain = gfc_ss_terminator;
7529 newss->data.info.subscript[n] = indexss;
7533 /* We don't add anything for sections, just remember this
7534 dimension for later. */
7535 newss->data.info.dim[newss->data.info.dimen
7536 + newss->data.info.codimen] = n;
7538 newss->data.info.dimen++;
7542 /* Create a GFC_SS_VECTOR index in which we can store
7543 the vector's descriptor. */
7544 indexss = gfc_get_ss ();
7545 indexss->type = GFC_SS_VECTOR;
7546 indexss->expr = ar->start[n];
7547 indexss->next = gfc_ss_terminator;
7548 indexss->loop_chain = gfc_ss_terminator;
7549 newss->data.info.subscript[n] = indexss;
7550 newss->data.info.dim[newss->data.info.dimen
7551 + newss->data.info.codimen] = n;
7553 newss->data.info.dimen++;
7557 /* We should know what sort of section it is by now. */
7561 /* We should have at least one non-elemental dimension. */
7562 gcc_assert (newss->data.info.dimen > 0);
7567 /* We should know what sort of section it is by now. */
7576 /* Walk an expression operator. If only one operand of a binary expression is
7577 scalar, we must also add the scalar term to the SS chain. */
7580 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7586 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7587 if (expr->value.op.op2 == NULL)
7590 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7592 /* All operands are scalar. Pass back and let the caller deal with it. */
7596 /* All operands require scalarization. */
7597 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7600 /* One of the operands needs scalarization, the other is scalar.
7601 Create a gfc_ss for the scalar expression. */
7602 newss = gfc_get_ss ();
7603 newss->type = GFC_SS_SCALAR;
7606 /* First operand is scalar. We build the chain in reverse order, so
7607 add the scalar SS after the second operand. */
7609 while (head && head->next != ss)
7611 /* Check we haven't somehow broken the chain. */
7615 newss->expr = expr->value.op.op1;
7617 else /* head2 == head */
7619 gcc_assert (head2 == head);
7620 /* Second operand is scalar. */
7621 newss->next = head2;
7623 newss->expr = expr->value.op.op2;
7630 /* Reverse a SS chain. */
7633 gfc_reverse_ss (gfc_ss * ss)
7638 gcc_assert (ss != NULL);
7640 head = gfc_ss_terminator;
7641 while (ss != gfc_ss_terminator)
7644 /* Check we didn't somehow break the chain. */
7645 gcc_assert (next != NULL);
7655 /* Walk the arguments of an elemental function. */
7658 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7666 head = gfc_ss_terminator;
7669 for (; arg; arg = arg->next)
7674 newss = gfc_walk_subexpr (head, arg->expr);
7677 /* Scalar argument. */
7678 newss = gfc_get_ss ();
7680 newss->expr = arg->expr;
7690 while (tail->next != gfc_ss_terminator)
7697 /* If all the arguments are scalar we don't need the argument SS. */
7698 gfc_free_ss_chain (head);
7703 /* Add it onto the existing chain. */
7709 /* Walk a function call. Scalar functions are passed back, and taken out of
7710 scalarization loops. For elemental functions we walk their arguments.
7711 The result of functions returning arrays is stored in a temporary outside
7712 the loop, so that the function is only called once. Hence we do not need
7713 to walk their arguments. */
7716 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7719 gfc_intrinsic_sym *isym;
7721 gfc_component *comp = NULL;
7724 isym = expr->value.function.isym;
7726 /* Handle intrinsic functions separately. */
7728 return gfc_walk_intrinsic_function (ss, expr, isym);
7730 sym = expr->value.function.esym;
7732 sym = expr->symtree->n.sym;
7734 /* A function that returns arrays. */
7735 gfc_is_proc_ptr_comp (expr, &comp);
7736 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7737 || (comp && comp->attr.dimension))
7739 newss = gfc_get_ss ();
7740 newss->type = GFC_SS_FUNCTION;
7743 newss->data.info.dimen = expr->rank;
7744 for (n = 0; n < newss->data.info.dimen; n++)
7745 newss->data.info.dim[n] = n;
7749 /* Walk the parameters of an elemental function. For now we always pass
7751 if (sym->attr.elemental)
7752 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7755 /* Scalar functions are OK as these are evaluated outside the scalarization
7756 loop. Pass back and let the caller deal with it. */
7761 /* An array temporary is constructed for array constructors. */
7764 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7769 newss = gfc_get_ss ();
7770 newss->type = GFC_SS_CONSTRUCTOR;
7773 newss->data.info.dimen = expr->rank;
7774 for (n = 0; n < expr->rank; n++)
7775 newss->data.info.dim[n] = n;
7781 /* Walk an expression. Add walked expressions to the head of the SS chain.
7782 A wholly scalar expression will not be added. */
7785 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7789 switch (expr->expr_type)
7792 head = gfc_walk_variable_expr (ss, expr);
7796 head = gfc_walk_op_expr (ss, expr);
7800 head = gfc_walk_function_expr (ss, expr);
7805 case EXPR_STRUCTURE:
7806 /* Pass back and let the caller deal with it. */
7810 head = gfc_walk_array_constructor (ss, expr);
7813 case EXPR_SUBSTRING:
7814 /* Pass back and let the caller deal with it. */
7818 internal_error ("bad expression type during walk (%d)",
7825 /* Entry point for expression walking.
7826 A return value equal to the passed chain means this is
7827 a scalar expression. It is up to the caller to take whatever action is
7828 necessary to translate these. */
7831 gfc_walk_expr (gfc_expr * expr)
7835 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7836 return gfc_reverse_ss (res);