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_INHIBIT_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 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2627 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2628 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2630 /* Use the actual tree type and not the wrapped coarray. */
2631 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), se->expr);
2635 /* Handle scalarized references separately. */
2636 if (ar->type != AR_ELEMENT)
2638 gfc_conv_scalarized_array_ref (se, ar);
2639 gfc_advance_se_ss_chain (se);
2643 index = gfc_index_zero_node;
2645 /* Calculate the offsets from all the dimensions. */
2646 for (n = 0; n < ar->dimen; n++)
2648 /* Calculate the index for this dimension. */
2649 gfc_init_se (&indexse, se);
2650 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2651 gfc_add_block_to_block (&se->pre, &indexse.pre);
2653 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2655 /* Check array bounds. */
2659 /* Evaluate the indexse.expr only once. */
2660 indexse.expr = save_expr (indexse.expr);
2663 tmp = gfc_conv_array_lbound (se->expr, n);
2664 if (sym->attr.temporary)
2666 gfc_init_se (&tmpse, se);
2667 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2668 gfc_array_index_type);
2669 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2673 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2675 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2676 "below lower bound of %%ld", n+1, sym->name);
2677 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2678 fold_convert (long_integer_type_node,
2680 fold_convert (long_integer_type_node, tmp));
2683 /* Upper bound, but not for the last dimension of assumed-size
2685 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2687 tmp = gfc_conv_array_ubound (se->expr, n);
2688 if (sym->attr.temporary)
2690 gfc_init_se (&tmpse, se);
2691 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2692 gfc_array_index_type);
2693 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2697 cond = fold_build2_loc (input_location, GT_EXPR,
2698 boolean_type_node, indexse.expr, tmp);
2699 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2700 "above upper bound of %%ld", n+1, sym->name);
2701 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2702 fold_convert (long_integer_type_node,
2704 fold_convert (long_integer_type_node, tmp));
2709 /* Multiply the index by the stride. */
2710 stride = gfc_conv_array_stride (se->expr, n);
2711 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2712 indexse.expr, stride);
2714 /* And add it to the total. */
2715 index = fold_build2_loc (input_location, PLUS_EXPR,
2716 gfc_array_index_type, index, tmp);
2719 tmp = gfc_conv_array_offset (se->expr);
2720 if (!integer_zerop (tmp))
2721 index = fold_build2_loc (input_location, PLUS_EXPR,
2722 gfc_array_index_type, index, tmp);
2724 /* Access the calculated element. */
2725 tmp = gfc_conv_array_data (se->expr);
2726 tmp = build_fold_indirect_ref (tmp);
2727 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2731 /* Generate the code to be executed immediately before entering a
2732 scalarization loop. */
2735 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2736 stmtblock_t * pblock)
2745 /* This code will be executed before entering the scalarization loop
2746 for this dimension. */
2747 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2749 if ((ss->useflags & flag) == 0)
2752 if (ss->type != GFC_SS_SECTION
2753 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2754 && ss->type != GFC_SS_COMPONENT)
2757 info = &ss->data.info;
2759 if (dim >= info->dimen)
2762 if (dim == info->dimen - 1)
2764 /* For the outermost loop calculate the offset due to any
2765 elemental dimensions. It will have been initialized with the
2766 base offset of the array. */
2769 for (i = 0; i < info->ref->u.ar.dimen; i++)
2771 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2774 gfc_init_se (&se, NULL);
2776 se.expr = info->descriptor;
2777 stride = gfc_conv_array_stride (info->descriptor, i);
2778 index = gfc_conv_array_index_offset (&se, info, i, -1,
2781 gfc_add_block_to_block (pblock, &se.pre);
2783 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2784 gfc_array_index_type,
2785 info->offset, index);
2786 info->offset = gfc_evaluate_now (info->offset, pblock);
2791 /* For the time being, the innermost loop is unconditionally on
2792 the first dimension of the scalarization loop. */
2793 gcc_assert (i == 0);
2794 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2796 /* Calculate the stride of the innermost loop. Hopefully this will
2797 allow the backend optimizers to do their stuff more effectively.
2799 info->stride0 = gfc_evaluate_now (stride, pblock);
2803 /* Add the offset for the previous loop dimension. */
2808 ar = &info->ref->u.ar;
2809 i = loop->order[dim + 1];
2817 gfc_init_se (&se, NULL);
2819 se.expr = info->descriptor;
2820 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2821 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2823 gfc_add_block_to_block (pblock, &se.pre);
2824 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2825 gfc_array_index_type, info->offset,
2827 info->offset = gfc_evaluate_now (info->offset, pblock);
2830 /* Remember this offset for the second loop. */
2831 if (dim == loop->temp_dim - 1)
2832 info->saved_offset = info->offset;
2837 /* Start a scalarized expression. Creates a scope and declares loop
2841 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2847 gcc_assert (!loop->array_parameter);
2849 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2851 n = loop->order[dim];
2853 gfc_start_block (&loop->code[n]);
2855 /* Create the loop variable. */
2856 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2858 if (dim < loop->temp_dim)
2862 /* Calculate values that will be constant within this loop. */
2863 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2865 gfc_start_block (pbody);
2869 /* Generates the actual loop code for a scalarization loop. */
2872 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2873 stmtblock_t * pbody)
2884 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2885 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2886 && n == loop->dimen - 1)
2888 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2889 init = make_tree_vec (1);
2890 cond = make_tree_vec (1);
2891 incr = make_tree_vec (1);
2893 /* Cycle statement is implemented with a goto. Exit statement must not
2894 be present for this loop. */
2895 exit_label = gfc_build_label_decl (NULL_TREE);
2896 TREE_USED (exit_label) = 1;
2898 /* Label for cycle statements (if needed). */
2899 tmp = build1_v (LABEL_EXPR, exit_label);
2900 gfc_add_expr_to_block (pbody, tmp);
2902 stmt = make_node (OMP_FOR);
2904 TREE_TYPE (stmt) = void_type_node;
2905 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2907 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2908 OMP_CLAUSE_SCHEDULE);
2909 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2910 = OMP_CLAUSE_SCHEDULE_STATIC;
2911 if (ompws_flags & OMPWS_NOWAIT)
2912 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2913 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2915 /* Initialize the loopvar. */
2916 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2918 OMP_FOR_INIT (stmt) = init;
2919 /* The exit condition. */
2920 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2922 loop->loopvar[n], loop->to[n]);
2923 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2924 OMP_FOR_COND (stmt) = cond;
2925 /* Increment the loopvar. */
2926 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2927 loop->loopvar[n], gfc_index_one_node);
2928 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2929 void_type_node, loop->loopvar[n], tmp);
2930 OMP_FOR_INCR (stmt) = incr;
2932 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2933 gfc_add_expr_to_block (&loop->code[n], stmt);
2937 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2938 && (loop->temp_ss == NULL);
2940 loopbody = gfc_finish_block (pbody);
2944 tmp = loop->from[n];
2945 loop->from[n] = loop->to[n];
2949 /* Initialize the loopvar. */
2950 if (loop->loopvar[n] != loop->from[n])
2951 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2953 exit_label = gfc_build_label_decl (NULL_TREE);
2955 /* Generate the loop body. */
2956 gfc_init_block (&block);
2958 /* The exit condition. */
2959 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2960 boolean_type_node, loop->loopvar[n], loop->to[n]);
2961 tmp = build1_v (GOTO_EXPR, exit_label);
2962 TREE_USED (exit_label) = 1;
2963 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2964 gfc_add_expr_to_block (&block, tmp);
2966 /* The main body. */
2967 gfc_add_expr_to_block (&block, loopbody);
2969 /* Increment the loopvar. */
2970 tmp = fold_build2_loc (input_location,
2971 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2972 gfc_array_index_type, loop->loopvar[n],
2973 gfc_index_one_node);
2975 gfc_add_modify (&block, loop->loopvar[n], tmp);
2977 /* Build the loop. */
2978 tmp = gfc_finish_block (&block);
2979 tmp = build1_v (LOOP_EXPR, tmp);
2980 gfc_add_expr_to_block (&loop->code[n], tmp);
2982 /* Add the exit label. */
2983 tmp = build1_v (LABEL_EXPR, exit_label);
2984 gfc_add_expr_to_block (&loop->code[n], tmp);
2990 /* Finishes and generates the loops for a scalarized expression. */
2993 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2998 stmtblock_t *pblock;
3002 /* Generate the loops. */
3003 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
3005 n = loop->order[dim];
3006 gfc_trans_scalarized_loop_end (loop, n, pblock);
3007 loop->loopvar[n] = NULL_TREE;
3008 pblock = &loop->code[n];
3011 tmp = gfc_finish_block (pblock);
3012 gfc_add_expr_to_block (&loop->pre, tmp);
3014 /* Clear all the used flags. */
3015 for (ss = loop->ss; ss; ss = ss->loop_chain)
3020 /* Finish the main body of a scalarized expression, and start the secondary
3024 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3028 stmtblock_t *pblock;
3032 /* We finish as many loops as are used by the temporary. */
3033 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3035 n = loop->order[dim];
3036 gfc_trans_scalarized_loop_end (loop, n, pblock);
3037 loop->loopvar[n] = NULL_TREE;
3038 pblock = &loop->code[n];
3041 /* We don't want to finish the outermost loop entirely. */
3042 n = loop->order[loop->temp_dim - 1];
3043 gfc_trans_scalarized_loop_end (loop, n, pblock);
3045 /* Restore the initial offsets. */
3046 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3048 if ((ss->useflags & 2) == 0)
3051 if (ss->type != GFC_SS_SECTION
3052 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3053 && ss->type != GFC_SS_COMPONENT)
3056 ss->data.info.offset = ss->data.info.saved_offset;
3059 /* Restart all the inner loops we just finished. */
3060 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3062 n = loop->order[dim];
3064 gfc_start_block (&loop->code[n]);
3066 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3068 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3071 /* Start a block for the secondary copying code. */
3072 gfc_start_block (body);
3076 /* Calculate the lower bound of an array section. */
3079 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3080 bool coarray, bool coarray_last)
3084 gfc_expr *stride = NULL;
3089 gcc_assert (ss->type == GFC_SS_SECTION);
3091 info = &ss->data.info;
3093 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3095 /* We use a zero-based index to access the vector. */
3096 info->start[dim] = gfc_index_zero_node;
3097 info->end[dim] = NULL;
3099 info->stride[dim] = gfc_index_one_node;
3103 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3104 desc = info->descriptor;
3105 start = info->ref->u.ar.start[dim];
3106 end = info->ref->u.ar.end[dim];
3108 stride = info->ref->u.ar.stride[dim];
3110 /* Calculate the start of the range. For vector subscripts this will
3111 be the range of the vector. */
3114 /* Specified section start. */
3115 gfc_init_se (&se, NULL);
3116 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3117 gfc_add_block_to_block (&loop->pre, &se.pre);
3118 info->start[dim] = se.expr;
3122 /* No lower bound specified so use the bound of the array. */
3123 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3125 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3127 /* Similarly calculate the end. Although this is not used in the
3128 scalarizer, it is needed when checking bounds and where the end
3129 is an expression with side-effects. */
3134 /* Specified section start. */
3135 gfc_init_se (&se, NULL);
3136 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3137 gfc_add_block_to_block (&loop->pre, &se.pre);
3138 info->end[dim] = se.expr;
3142 /* No upper bound specified so use the bound of the array. */
3143 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3145 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3148 /* Calculate the stride. */
3149 if (!coarray && stride == NULL)
3150 info->stride[dim] = gfc_index_one_node;
3153 gfc_init_se (&se, NULL);
3154 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3155 gfc_add_block_to_block (&loop->pre, &se.pre);
3156 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3161 /* Calculates the range start and stride for a SS chain. Also gets the
3162 descriptor and data pointer. The range of vector subscripts is the size
3163 of the vector. Array bounds are also checked. */
3166 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3174 /* Determine the rank of the loop. */
3176 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3180 case GFC_SS_SECTION:
3181 case GFC_SS_CONSTRUCTOR:
3182 case GFC_SS_FUNCTION:
3183 case GFC_SS_COMPONENT:
3184 loop->dimen = ss->data.info.dimen;
3185 loop->codimen = ss->data.info.codimen;
3188 /* As usual, lbound and ubound are exceptions!. */
3189 case GFC_SS_INTRINSIC:
3190 switch (ss->expr->value.function.isym->id)
3192 case GFC_ISYM_LBOUND:
3193 case GFC_ISYM_UBOUND:
3194 loop->dimen = ss->data.info.dimen;
3198 case GFC_ISYM_LCOBOUND:
3199 case GFC_ISYM_UCOBOUND:
3200 case GFC_ISYM_THIS_IMAGE:
3201 loop->dimen = ss->data.info.dimen;
3202 loop->codimen = ss->data.info.codimen;
3214 /* We should have determined the rank of the expression by now. If
3215 not, that's bad news. */
3216 gcc_assert (loop->dimen + loop->codimen != 0);
3218 /* Loop over all the SS in the chain. */
3219 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3221 if (ss->expr && ss->expr->shape && !ss->shape)
3222 ss->shape = ss->expr->shape;
3226 case GFC_SS_SECTION:
3227 /* Get the descriptor for the array. */
3228 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3230 for (n = 0; n < ss->data.info.dimen; n++)
3231 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3233 for (n = ss->data.info.dimen;
3234 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3235 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3236 n == ss->data.info.dimen
3237 + ss->data.info.codimen -1);
3241 case GFC_SS_INTRINSIC:
3242 switch (ss->expr->value.function.isym->id)
3244 /* Fall through to supply start and stride. */
3245 case GFC_ISYM_LBOUND:
3246 case GFC_ISYM_UBOUND:
3247 case GFC_ISYM_LCOBOUND:
3248 case GFC_ISYM_UCOBOUND:
3249 case GFC_ISYM_THIS_IMAGE:
3256 case GFC_SS_CONSTRUCTOR:
3257 case GFC_SS_FUNCTION:
3258 for (n = 0; n < ss->data.info.dimen; n++)
3260 ss->data.info.start[n] = gfc_index_zero_node;
3261 ss->data.info.end[n] = gfc_index_zero_node;
3262 ss->data.info.stride[n] = gfc_index_one_node;
3271 /* The rest is just runtime bound checking. */
3272 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3275 tree lbound, ubound;
3277 tree size[GFC_MAX_DIMENSIONS];
3278 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3283 gfc_start_block (&block);
3285 for (n = 0; n < loop->dimen; n++)
3286 size[n] = NULL_TREE;
3288 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3292 if (ss->type != GFC_SS_SECTION)
3295 /* Catch allocatable lhs in f2003. */
3296 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3299 gfc_start_block (&inner);
3301 /* TODO: range checking for mapped dimensions. */
3302 info = &ss->data.info;
3304 /* This code only checks ranges. Elemental and vector
3305 dimensions are checked later. */
3306 for (n = 0; n < loop->dimen; n++)
3311 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3314 if (dim == info->ref->u.ar.dimen - 1
3315 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3316 check_upper = false;
3320 /* Zero stride is not allowed. */
3321 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3322 info->stride[dim], gfc_index_zero_node);
3323 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3324 "of array '%s'", dim + 1, ss->expr->symtree->name);
3325 gfc_trans_runtime_check (true, false, tmp, &inner,
3326 &ss->expr->where, msg);
3329 desc = ss->data.info.descriptor;
3331 /* This is the run-time equivalent of resolve.c's
3332 check_dimension(). The logical is more readable there
3333 than it is here, with all the trees. */
3334 lbound = gfc_conv_array_lbound (desc, dim);
3335 end = info->end[dim];
3337 ubound = gfc_conv_array_ubound (desc, dim);
3341 /* non_zerosized is true when the selected range is not
3343 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3344 boolean_type_node, info->stride[dim],
3345 gfc_index_zero_node);
3346 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3347 info->start[dim], end);
3348 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3349 boolean_type_node, stride_pos, tmp);
3351 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3353 info->stride[dim], gfc_index_zero_node);
3354 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3355 info->start[dim], end);
3356 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3359 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3361 stride_pos, stride_neg);
3363 /* Check the start of the range against the lower and upper
3364 bounds of the array, if the range is not empty.
3365 If upper bound is present, include both bounds in the
3369 tmp = fold_build2_loc (input_location, LT_EXPR,
3371 info->start[dim], lbound);
3372 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3374 non_zerosized, tmp);
3375 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3377 info->start[dim], ubound);
3378 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3380 non_zerosized, tmp2);
3381 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3382 "outside of expected range (%%ld:%%ld)",
3383 dim + 1, ss->expr->symtree->name);
3384 gfc_trans_runtime_check (true, false, tmp, &inner,
3385 &ss->expr->where, msg,
3386 fold_convert (long_integer_type_node, info->start[dim]),
3387 fold_convert (long_integer_type_node, lbound),
3388 fold_convert (long_integer_type_node, ubound));
3389 gfc_trans_runtime_check (true, false, tmp2, &inner,
3390 &ss->expr->where, msg,
3391 fold_convert (long_integer_type_node, info->start[dim]),
3392 fold_convert (long_integer_type_node, lbound),
3393 fold_convert (long_integer_type_node, ubound));
3398 tmp = fold_build2_loc (input_location, LT_EXPR,
3400 info->start[dim], lbound);
3401 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3402 boolean_type_node, non_zerosized, tmp);
3403 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3404 "below lower bound of %%ld",
3405 dim + 1, ss->expr->symtree->name);
3406 gfc_trans_runtime_check (true, false, tmp, &inner,
3407 &ss->expr->where, msg,
3408 fold_convert (long_integer_type_node, info->start[dim]),
3409 fold_convert (long_integer_type_node, lbound));
3413 /* Compute the last element of the range, which is not
3414 necessarily "end" (think 0:5:3, which doesn't contain 5)
3415 and check it against both lower and upper bounds. */
3417 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3418 gfc_array_index_type, end,
3420 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3421 gfc_array_index_type, tmp,
3423 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3424 gfc_array_index_type, end, tmp);
3425 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3426 boolean_type_node, tmp, lbound);
3427 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3428 boolean_type_node, non_zerosized, tmp2);
3431 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3432 boolean_type_node, tmp, ubound);
3433 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3434 boolean_type_node, non_zerosized, tmp3);
3435 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3436 "outside of expected range (%%ld:%%ld)",
3437 dim + 1, ss->expr->symtree->name);
3438 gfc_trans_runtime_check (true, false, tmp2, &inner,
3439 &ss->expr->where, msg,
3440 fold_convert (long_integer_type_node, tmp),
3441 fold_convert (long_integer_type_node, ubound),
3442 fold_convert (long_integer_type_node, lbound));
3443 gfc_trans_runtime_check (true, false, tmp3, &inner,
3444 &ss->expr->where, msg,
3445 fold_convert (long_integer_type_node, tmp),
3446 fold_convert (long_integer_type_node, ubound),
3447 fold_convert (long_integer_type_node, lbound));
3452 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3453 "below lower bound of %%ld",
3454 dim + 1, ss->expr->symtree->name);
3455 gfc_trans_runtime_check (true, false, tmp2, &inner,
3456 &ss->expr->where, msg,
3457 fold_convert (long_integer_type_node, tmp),
3458 fold_convert (long_integer_type_node, lbound));
3462 /* Check the section sizes match. */
3463 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3464 gfc_array_index_type, end,
3466 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3467 gfc_array_index_type, tmp,
3469 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3470 gfc_array_index_type,
3471 gfc_index_one_node, tmp);
3472 tmp = fold_build2_loc (input_location, MAX_EXPR,
3473 gfc_array_index_type, tmp,
3474 build_int_cst (gfc_array_index_type, 0));
3475 /* We remember the size of the first section, and check all the
3476 others against this. */
3479 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3480 boolean_type_node, tmp, size[n]);
3481 asprintf (&msg, "Array bound mismatch for dimension %d "
3482 "of array '%s' (%%ld/%%ld)",
3483 dim + 1, ss->expr->symtree->name);
3485 gfc_trans_runtime_check (true, false, tmp3, &inner,
3486 &ss->expr->where, msg,
3487 fold_convert (long_integer_type_node, tmp),
3488 fold_convert (long_integer_type_node, size[n]));
3493 size[n] = gfc_evaluate_now (tmp, &inner);
3496 tmp = gfc_finish_block (&inner);
3498 /* For optional arguments, only check bounds if the argument is
3500 if (ss->expr->symtree->n.sym->attr.optional
3501 || ss->expr->symtree->n.sym->attr.not_always_present)
3502 tmp = build3_v (COND_EXPR,
3503 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3504 tmp, build_empty_stmt (input_location));
3506 gfc_add_expr_to_block (&block, tmp);
3510 tmp = gfc_finish_block (&block);
3511 gfc_add_expr_to_block (&loop->pre, tmp);
3515 /* Return true if both symbols could refer to the same data object. Does
3516 not take account of aliasing due to equivalence statements. */
3519 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3520 bool lsym_target, bool rsym_pointer, bool rsym_target)
3522 /* Aliasing isn't possible if the symbols have different base types. */
3523 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3526 /* Pointers can point to other pointers and target objects. */
3528 if ((lsym_pointer && (rsym_pointer || rsym_target))
3529 || (rsym_pointer && (lsym_pointer || lsym_target)))
3532 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3533 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3535 if (lsym_target && rsym_target
3536 && ((lsym->attr.dummy && !lsym->attr.contiguous
3537 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3538 || (rsym->attr.dummy && !rsym->attr.contiguous
3539 && (!rsym->attr.dimension
3540 || rsym->as->type == AS_ASSUMED_SHAPE))))
3547 /* Return true if the two SS could be aliased, i.e. both point to the same data
3549 /* TODO: resolve aliases based on frontend expressions. */
3552 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3558 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3560 lsym = lss->expr->symtree->n.sym;
3561 rsym = rss->expr->symtree->n.sym;
3563 lsym_pointer = lsym->attr.pointer;
3564 lsym_target = lsym->attr.target;
3565 rsym_pointer = rsym->attr.pointer;
3566 rsym_target = rsym->attr.target;
3568 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3569 rsym_pointer, rsym_target))
3572 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3573 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3576 /* For derived types we must check all the component types. We can ignore
3577 array references as these will have the same base type as the previous
3579 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3581 if (lref->type != REF_COMPONENT)
3584 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3585 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3587 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3588 rsym_pointer, rsym_target))
3591 if ((lsym_pointer && (rsym_pointer || rsym_target))
3592 || (rsym_pointer && (lsym_pointer || lsym_target)))
3594 if (gfc_compare_types (&lref->u.c.component->ts,
3599 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3602 if (rref->type != REF_COMPONENT)
3605 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3606 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3608 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3609 lsym_pointer, lsym_target,
3610 rsym_pointer, rsym_target))
3613 if ((lsym_pointer && (rsym_pointer || rsym_target))
3614 || (rsym_pointer && (lsym_pointer || lsym_target)))
3616 if (gfc_compare_types (&lref->u.c.component->ts,
3617 &rref->u.c.sym->ts))
3619 if (gfc_compare_types (&lref->u.c.sym->ts,
3620 &rref->u.c.component->ts))
3622 if (gfc_compare_types (&lref->u.c.component->ts,
3623 &rref->u.c.component->ts))
3629 lsym_pointer = lsym->attr.pointer;
3630 lsym_target = lsym->attr.target;
3631 lsym_pointer = lsym->attr.pointer;
3632 lsym_target = lsym->attr.target;
3634 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3636 if (rref->type != REF_COMPONENT)
3639 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3640 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3642 if (symbols_could_alias (rref->u.c.sym, lsym,
3643 lsym_pointer, lsym_target,
3644 rsym_pointer, rsym_target))
3647 if ((lsym_pointer && (rsym_pointer || rsym_target))
3648 || (rsym_pointer && (lsym_pointer || lsym_target)))
3650 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3659 /* Resolve array data dependencies. Creates a temporary if required. */
3660 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3664 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3673 loop->temp_ss = NULL;
3675 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3677 if (ss->type != GFC_SS_SECTION)
3680 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3682 if (gfc_could_be_alias (dest, ss)
3683 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3691 lref = dest->expr->ref;
3692 rref = ss->expr->ref;
3694 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3699 for (i = 0; i < dest->data.info.dimen; i++)
3700 for (j = 0; j < ss->data.info.dimen; j++)
3702 && dest->data.info.dim[i] == ss->data.info.dim[j])
3704 /* If we don't access array elements in the same order,
3705 there is a dependency. */
3710 /* TODO : loop shifting. */
3713 /* Mark the dimensions for LOOP SHIFTING */
3714 for (n = 0; n < loop->dimen; n++)
3716 int dim = dest->data.info.dim[n];
3718 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3720 else if (! gfc_is_same_range (&lref->u.ar,
3721 &rref->u.ar, dim, 0))
3725 /* Put all the dimensions with dependencies in the
3728 for (n = 0; n < loop->dimen; n++)
3730 gcc_assert (loop->order[n] == n);
3732 loop->order[dim++] = n;
3734 for (n = 0; n < loop->dimen; n++)
3737 loop->order[dim++] = n;
3740 gcc_assert (dim == loop->dimen);
3751 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3752 if (GFC_ARRAY_TYPE_P (base_type)
3753 || GFC_DESCRIPTOR_TYPE_P (base_type))
3754 base_type = gfc_get_element_type (base_type);
3755 loop->temp_ss = gfc_get_ss ();
3756 loop->temp_ss->type = GFC_SS_TEMP;
3757 loop->temp_ss->data.temp.type = base_type;
3758 loop->temp_ss->string_length = dest->string_length;
3759 loop->temp_ss->data.temp.dimen = loop->dimen;
3760 loop->temp_ss->data.temp.codimen = loop->codimen;
3761 loop->temp_ss->next = gfc_ss_terminator;
3762 gfc_add_ss_to_loop (loop, loop->temp_ss);
3765 loop->temp_ss = NULL;
3769 /* Initialize the scalarization loop. Creates the loop variables. Determines
3770 the range of the loop variables. Creates a temporary if required.
3771 Calculates how to transform from loop variables to array indices for each
3772 expression. Also generates code for scalar expressions which have been
3773 moved outside the loop. */
3776 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3778 int n, dim, spec_dim;
3780 gfc_ss_info *specinfo;
3783 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3784 bool dynamic[GFC_MAX_DIMENSIONS];
3789 for (n = 0; n < loop->dimen + loop->codimen; n++)
3793 /* We use one SS term, and use that to determine the bounds of the
3794 loop for this dimension. We try to pick the simplest term. */
3795 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3797 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3800 info = &ss->data.info;
3803 if (loopspec[n] != NULL)
3805 specinfo = &loopspec[n]->data.info;
3806 spec_dim = specinfo->dim[n];
3810 /* Silence unitialized warnings. */
3817 gcc_assert (ss->shape[dim]);
3818 /* The frontend has worked out the size for us. */
3820 || !loopspec[n]->shape
3821 || !integer_zerop (specinfo->start[spec_dim]))
3822 /* Prefer zero-based descriptors if possible. */
3827 if (ss->type == GFC_SS_CONSTRUCTOR)
3829 gfc_constructor_base base;
3830 /* An unknown size constructor will always be rank one.
3831 Higher rank constructors will either have known shape,
3832 or still be wrapped in a call to reshape. */
3833 gcc_assert (loop->dimen == 1);
3835 /* Always prefer to use the constructor bounds if the size
3836 can be determined at compile time. Prefer not to otherwise,
3837 since the general case involves realloc, and it's better to
3838 avoid that overhead if possible. */
3839 base = ss->expr->value.constructor;
3840 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3841 if (!dynamic[n] || !loopspec[n])
3846 /* TODO: Pick the best bound if we have a choice between a
3847 function and something else. */
3848 if (ss->type == GFC_SS_FUNCTION)
3854 /* Avoid using an allocatable lhs in an assignment, since
3855 there might be a reallocation coming. */
3856 if (loopspec[n] && ss->is_alloc_lhs)
3859 if (ss->type != GFC_SS_SECTION)
3864 /* Criteria for choosing a loop specifier (most important first):
3865 doesn't need realloc
3871 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3872 || n >= loop->dimen)
3874 else if (integer_onep (info->stride[dim])
3875 && !integer_onep (specinfo->stride[spec_dim]))
3877 else if (INTEGER_CST_P (info->stride[dim])
3878 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3880 else if (INTEGER_CST_P (info->start[dim])
3881 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3883 /* We don't work out the upper bound.
3884 else if (INTEGER_CST_P (info->finish[n])
3885 && ! INTEGER_CST_P (specinfo->finish[n]))
3886 loopspec[n] = ss; */
3889 /* We should have found the scalarization loop specifier. If not,
3891 gcc_assert (loopspec[n]);
3893 info = &loopspec[n]->data.info;
3896 /* Set the extents of this range. */
3897 cshape = loopspec[n]->shape;
3898 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3899 && INTEGER_CST_P (info->stride[dim]))
3901 loop->from[n] = info->start[dim];
3902 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3903 mpz_sub_ui (i, i, 1);
3904 /* To = from + (size - 1) * stride. */
3905 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3906 if (!integer_onep (info->stride[dim]))
3907 tmp = fold_build2_loc (input_location, MULT_EXPR,
3908 gfc_array_index_type, tmp,
3910 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3911 gfc_array_index_type,
3912 loop->from[n], tmp);
3916 loop->from[n] = info->start[dim];
3917 switch (loopspec[n]->type)
3919 case GFC_SS_CONSTRUCTOR:
3920 /* The upper bound is calculated when we expand the
3922 gcc_assert (loop->to[n] == NULL_TREE);
3925 case GFC_SS_SECTION:
3926 /* Use the end expression if it exists and is not constant,
3927 so that it is only evaluated once. */
3928 loop->to[n] = info->end[dim];
3931 case GFC_SS_FUNCTION:
3932 /* The loop bound will be set when we generate the call. */
3933 gcc_assert (loop->to[n] == NULL_TREE);
3941 /* Transform everything so we have a simple incrementing variable. */
3942 if (n < loop->dimen && integer_onep (info->stride[dim]))
3943 info->delta[dim] = gfc_index_zero_node;
3944 else if (n < loop->dimen)
3946 /* Set the delta for this section. */
3947 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3948 /* Number of iterations is (end - start + step) / step.
3949 with start = 0, this simplifies to
3951 for (i = 0; i<=last; i++){...}; */
3952 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3953 gfc_array_index_type, loop->to[n],
3955 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3956 gfc_array_index_type, tmp, info->stride[dim]);
3957 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3958 tmp, build_int_cst (gfc_array_index_type, -1));
3959 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3960 /* Make the loop variable start at 0. */
3961 loop->from[n] = gfc_index_zero_node;
3965 /* Add all the scalar code that can be taken out of the loops.
3966 This may include calculating the loop bounds, so do it before
3967 allocating the temporary. */
3968 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3970 /* If we want a temporary then create it. */
3971 if (loop->temp_ss != NULL)
3973 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3975 /* Make absolutely sure that this is a complete type. */
3976 if (loop->temp_ss->string_length)
3977 loop->temp_ss->data.temp.type
3978 = gfc_get_character_type_len_for_eltype
3979 (TREE_TYPE (loop->temp_ss->data.temp.type),
3980 loop->temp_ss->string_length);
3982 tmp = loop->temp_ss->data.temp.type;
3983 n = loop->temp_ss->data.temp.dimen;
3984 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3985 loop->temp_ss->type = GFC_SS_SECTION;
3986 loop->temp_ss->data.info.dimen = n;
3988 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3989 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3990 loop->temp_ss->data.info.dim[n] = n;
3992 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3993 &loop->temp_ss->data.info, tmp, NULL_TREE,
3994 false, true, false, where);
3997 for (n = 0; n < loop->temp_dim; n++)
3998 loopspec[loop->order[n]] = NULL;
4002 /* For array parameters we don't have loop variables, so don't calculate the
4004 if (loop->array_parameter)
4007 /* Calculate the translation from loop variables to array indices. */
4008 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4010 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4011 && ss->type != GFC_SS_CONSTRUCTOR)
4015 info = &ss->data.info;
4017 for (n = 0; n < info->dimen; n++)
4019 /* If we are specifying the range the delta is already set. */
4020 if (loopspec[n] != ss)
4022 dim = ss->data.info.dim[n];
4024 /* Calculate the offset relative to the loop variable.
4025 First multiply by the stride. */
4026 tmp = loop->from[n];
4027 if (!integer_onep (info->stride[dim]))
4028 tmp = fold_build2_loc (input_location, MULT_EXPR,
4029 gfc_array_index_type,
4030 tmp, info->stride[dim]);
4032 /* Then subtract this from our starting value. */
4033 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4034 gfc_array_index_type,
4035 info->start[dim], tmp);
4037 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4044 /* Calculate the size of a given array dimension from the bounds. This
4045 is simply (ubound - lbound + 1) if this expression is positive
4046 or 0 if it is negative (pick either one if it is zero). Optionally
4047 (if or_expr is present) OR the (expression != 0) condition to it. */
4050 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4055 /* Calculate (ubound - lbound + 1). */
4056 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4058 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4059 gfc_index_one_node);
4061 /* Check whether the size for this dimension is negative. */
4062 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4063 gfc_index_zero_node);
4064 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4065 gfc_index_zero_node, res);
4067 /* Build OR expression. */
4069 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4070 boolean_type_node, *or_expr, cond);
4076 /* For an array descriptor, get the total number of elements. This is just
4077 the product of the extents along from_dim to to_dim. */
4080 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4085 res = gfc_index_one_node;
4087 for (dim = from_dim; dim < to_dim; ++dim)
4093 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4094 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4096 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4097 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4105 /* Full size of an array. */
4108 gfc_conv_descriptor_size (tree desc, int rank)
4110 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4114 /* Size of a coarray for all dimensions but the last. */
4117 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4119 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4123 /* Fills in an array descriptor, and returns the size of the array.
4124 The size will be a simple_val, ie a variable or a constant. Also
4125 calculates the offset of the base. The pointer argument overflow,
4126 which should be of integer type, will increase in value if overflow
4127 occurs during the size calculation. Returns the size of the array.
4131 for (n = 0; n < rank; n++)
4133 a.lbound[n] = specified_lower_bound;
4134 offset = offset + a.lbond[n] * stride;
4136 a.ubound[n] = specified_upper_bound;
4137 a.stride[n] = stride;
4138 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4139 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4140 stride = stride * size;
4142 element_size = sizeof (array element);
4143 stride = (size_t) stride;
4144 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4145 stride = stride * element_size;
4151 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4152 gfc_expr ** lower, gfc_expr ** upper,
4153 stmtblock_t * pblock, tree * overflow)
4166 stmtblock_t thenblock;
4167 stmtblock_t elseblock;
4172 type = TREE_TYPE (descriptor);
4174 stride = gfc_index_one_node;
4175 offset = gfc_index_zero_node;
4177 /* Set the dtype. */
4178 tmp = gfc_conv_descriptor_dtype (descriptor);
4179 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4181 or_expr = boolean_false_node;
4183 for (n = 0; n < rank; n++)
4188 /* We have 3 possibilities for determining the size of the array:
4189 lower == NULL => lbound = 1, ubound = upper[n]
4190 upper[n] = NULL => lbound = 1, ubound = lower[n]
4191 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4194 /* Set lower bound. */
4195 gfc_init_se (&se, NULL);
4197 se.expr = gfc_index_one_node;
4200 gcc_assert (lower[n]);
4203 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4204 gfc_add_block_to_block (pblock, &se.pre);
4208 se.expr = gfc_index_one_node;
4212 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4214 conv_lbound = se.expr;
4216 /* Work out the offset for this component. */
4217 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4219 offset = fold_build2_loc (input_location, MINUS_EXPR,
4220 gfc_array_index_type, offset, tmp);
4222 /* Set upper bound. */
4223 gfc_init_se (&se, NULL);
4224 gcc_assert (ubound);
4225 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4226 gfc_add_block_to_block (pblock, &se.pre);
4228 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4229 gfc_rank_cst[n], se.expr);
4230 conv_ubound = se.expr;
4232 /* Store the stride. */
4233 gfc_conv_descriptor_stride_set (pblock, descriptor,
4234 gfc_rank_cst[n], stride);
4236 /* Calculate size and check whether extent is negative. */
4237 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4238 size = gfc_evaluate_now (size, pblock);
4240 /* Check whether multiplying the stride by the number of
4241 elements in this dimension would overflow. We must also check
4242 whether the current dimension has zero size in order to avoid
4245 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4246 gfc_array_index_type,
4247 fold_convert (gfc_array_index_type,
4248 TYPE_MAX_VALUE (gfc_array_index_type)),
4250 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4251 boolean_type_node, tmp, stride));
4252 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4253 integer_one_node, integer_zero_node);
4254 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4255 boolean_type_node, size,
4256 gfc_index_zero_node));
4257 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4258 integer_zero_node, tmp);
4259 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4261 *overflow = gfc_evaluate_now (tmp, pblock);
4263 /* Multiply the stride by the number of elements in this dimension. */
4264 stride = fold_build2_loc (input_location, MULT_EXPR,
4265 gfc_array_index_type, stride, size);
4266 stride = gfc_evaluate_now (stride, pblock);
4269 for (n = rank; n < rank + corank; n++)
4273 /* Set lower bound. */
4274 gfc_init_se (&se, NULL);
4275 if (lower == NULL || lower[n] == NULL)
4277 gcc_assert (n == rank + corank - 1);
4278 se.expr = gfc_index_one_node;
4282 if (ubound || n == rank + corank - 1)
4284 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4285 gfc_add_block_to_block (pblock, &se.pre);
4289 se.expr = gfc_index_one_node;
4293 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4296 if (n < rank + corank - 1)
4298 gfc_init_se (&se, NULL);
4299 gcc_assert (ubound);
4300 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4301 gfc_add_block_to_block (pblock, &se.pre);
4302 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4303 gfc_rank_cst[n], se.expr);
4307 /* The stride is the number of elements in the array, so multiply by the
4308 size of an element to get the total size. */
4309 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4310 /* Convert to size_t. */
4311 element_size = fold_convert (size_type_node, tmp);
4312 stride = fold_convert (size_type_node, stride);
4314 /* First check for overflow. Since an array of type character can
4315 have zero element_size, we must check for that before
4317 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4319 TYPE_MAX_VALUE (size_type_node), element_size);
4320 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4321 boolean_type_node, tmp, stride));
4322 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4323 integer_one_node, integer_zero_node);
4324 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4325 boolean_type_node, element_size,
4326 build_int_cst (size_type_node, 0)));
4327 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4328 integer_zero_node, tmp);
4329 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4331 *overflow = gfc_evaluate_now (tmp, pblock);
4333 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4334 stride, element_size);
4336 if (poffset != NULL)
4338 offset = gfc_evaluate_now (offset, pblock);
4342 if (integer_zerop (or_expr))
4344 if (integer_onep (or_expr))
4345 return build_int_cst (size_type_node, 0);
4347 var = gfc_create_var (TREE_TYPE (size), "size");
4348 gfc_start_block (&thenblock);
4349 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4350 thencase = gfc_finish_block (&thenblock);
4352 gfc_start_block (&elseblock);
4353 gfc_add_modify (&elseblock, var, size);
4354 elsecase = gfc_finish_block (&elseblock);
4356 tmp = gfc_evaluate_now (or_expr, pblock);
4357 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4358 gfc_add_expr_to_block (pblock, tmp);
4364 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4365 the work for an ALLOCATE statement. */
4369 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
4377 tree overflow; /* Boolean storing whether size calculation overflows. */
4380 stmtblock_t elseblock;
4383 gfc_ref *ref, *prev_ref = NULL;
4384 bool allocatable_array, coarray;
4388 /* Find the last reference in the chain. */
4389 while (ref && ref->next != NULL)
4391 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4392 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4397 if (ref == NULL || ref->type != REF_ARRAY)
4402 allocatable_array = expr->symtree->n.sym->attr.allocatable;
4403 coarray = expr->symtree->n.sym->attr.codimension;
4407 allocatable_array = prev_ref->u.c.component->attr.allocatable;
4408 coarray = prev_ref->u.c.component->attr.codimension;
4411 /* Return if this is a scalar coarray. */
4412 if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
4413 || (prev_ref && !prev_ref->u.c.component->attr.dimension))
4415 gcc_assert (coarray);
4419 /* Figure out the size of the array. */
4420 switch (ref->u.ar.type)
4426 upper = ref->u.ar.start;
4432 lower = ref->u.ar.start;
4433 upper = ref->u.ar.end;
4437 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4439 lower = ref->u.ar.as->lower;
4440 upper = ref->u.ar.as->upper;
4448 overflow = integer_zero_node;
4449 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4450 ref->u.ar.as->corank, &offset, lower, upper,
4451 &se->pre, &overflow);
4453 var_overflow = gfc_create_var (integer_type_node, "overflow");
4454 gfc_add_modify (&se->pre, var_overflow, overflow);
4456 /* Generate the block of code handling overflow. */
4457 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
4458 ("Integer overflow when calculating the amount of "
4459 "memory to allocate"));
4460 error = build_call_expr_loc (input_location,
4461 gfor_fndecl_runtime_error, 1, msg);
4463 if (pstat != NULL_TREE && !integer_zerop (pstat))
4465 /* Set the status variable if it's present. */
4466 stmtblock_t set_status_block;
4467 tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
4469 gfc_start_block (&set_status_block);
4470 gfc_add_modify (&set_status_block,
4471 fold_build1_loc (input_location, INDIRECT_REF,
4472 status_type, pstat),
4473 build_int_cst (status_type, LIBERROR_ALLOCATION));
4475 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4476 pstat, build_int_cst (TREE_TYPE (pstat), 0));
4477 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
4478 error, gfc_finish_block (&set_status_block));
4481 gfc_start_block (&elseblock);
4483 /* Allocate memory to store the data. */
4484 pointer = gfc_conv_descriptor_data_get (se->expr);
4485 STRIP_NOPS (pointer);
4487 /* The allocate_array variants take the old pointer as first argument. */
4488 if (allocatable_array)
4489 tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr);
4491 tmp = gfc_allocate_with_status (&elseblock, size, pstat);
4492 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
4495 gfc_add_expr_to_block (&elseblock, tmp);
4497 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4498 var_overflow, integer_zero_node));
4499 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4500 error, gfc_finish_block (&elseblock));
4502 gfc_add_expr_to_block (&se->pre, tmp);
4504 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4506 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4507 && expr->ts.u.derived->attr.alloc_comp)
4509 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4510 ref->u.ar.as->rank);
4511 gfc_add_expr_to_block (&se->pre, tmp);
4518 /* Deallocate an array variable. Also used when an allocated variable goes
4523 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4529 gfc_start_block (&block);
4530 /* Get a pointer to the data. */
4531 var = gfc_conv_descriptor_data_get (descriptor);
4534 /* Parameter is the address of the data component. */
4535 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4536 gfc_add_expr_to_block (&block, tmp);
4538 /* Zero the data pointer. */
4539 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4540 var, build_int_cst (TREE_TYPE (var), 0));
4541 gfc_add_expr_to_block (&block, tmp);
4543 return gfc_finish_block (&block);
4547 /* Create an array constructor from an initialization expression.
4548 We assume the frontend already did any expansions and conversions. */
4551 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4557 unsigned HOST_WIDE_INT lo;
4559 VEC(constructor_elt,gc) *v = NULL;
4561 switch (expr->expr_type)
4564 case EXPR_STRUCTURE:
4565 /* A single scalar or derived type value. Create an array with all
4566 elements equal to that value. */
4567 gfc_init_se (&se, NULL);
4569 if (expr->expr_type == EXPR_CONSTANT)
4570 gfc_conv_constant (&se, expr);
4572 gfc_conv_structure (&se, expr, 1);
4574 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4575 gcc_assert (tmp && INTEGER_CST_P (tmp));
4576 hi = TREE_INT_CST_HIGH (tmp);
4577 lo = TREE_INT_CST_LOW (tmp);
4581 /* This will probably eat buckets of memory for large arrays. */
4582 while (hi != 0 || lo != 0)
4584 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4592 /* Create a vector of all the elements. */
4593 for (c = gfc_constructor_first (expr->value.constructor);
4594 c; c = gfc_constructor_next (c))
4598 /* Problems occur when we get something like
4599 integer :: a(lots) = (/(i, i=1, lots)/) */
4600 gfc_fatal_error ("The number of elements in the array constructor "
4601 "at %L requires an increase of the allowed %d "
4602 "upper limit. See -fmax-array-constructor "
4603 "option", &expr->where,
4604 gfc_option.flag_max_array_constructor);
4607 if (mpz_cmp_si (c->offset, 0) != 0)
4608 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4612 gfc_init_se (&se, NULL);
4613 switch (c->expr->expr_type)
4616 gfc_conv_constant (&se, c->expr);
4617 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4620 case EXPR_STRUCTURE:
4621 gfc_conv_structure (&se, c->expr, 1);
4622 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4627 /* Catch those occasional beasts that do not simplify
4628 for one reason or another, assuming that if they are
4629 standard defying the frontend will catch them. */
4630 gfc_conv_expr (&se, c->expr);
4631 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4638 return gfc_build_null_descriptor (type);
4644 /* Create a constructor from the list of elements. */
4645 tmp = build_constructor (type, v);
4646 TREE_CONSTANT (tmp) = 1;
4651 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4652 returns the size (in elements) of the array. */
4655 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4656 stmtblock_t * pblock)
4671 size = gfc_index_one_node;
4672 offset = gfc_index_zero_node;
4673 for (dim = 0; dim < as->rank; dim++)
4675 /* Evaluate non-constant array bound expressions. */
4676 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4677 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4679 gfc_init_se (&se, NULL);
4680 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4681 gfc_add_block_to_block (pblock, &se.pre);
4682 gfc_add_modify (pblock, lbound, se.expr);
4684 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4685 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4687 gfc_init_se (&se, NULL);
4688 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4689 gfc_add_block_to_block (pblock, &se.pre);
4690 gfc_add_modify (pblock, ubound, se.expr);
4692 /* The offset of this dimension. offset = offset - lbound * stride. */
4693 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4695 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4698 /* The size of this dimension, and the stride of the next. */
4699 if (dim + 1 < as->rank)
4700 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4702 stride = GFC_TYPE_ARRAY_SIZE (type);
4704 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4706 /* Calculate stride = size * (ubound + 1 - lbound). */
4707 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4708 gfc_array_index_type,
4709 gfc_index_one_node, lbound);
4710 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4711 gfc_array_index_type, ubound, tmp);
4712 tmp = fold_build2_loc (input_location, MULT_EXPR,
4713 gfc_array_index_type, size, tmp);
4715 gfc_add_modify (pblock, stride, tmp);
4717 stride = gfc_evaluate_now (tmp, pblock);
4719 /* Make sure that negative size arrays are translated
4720 to being zero size. */
4721 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4722 stride, gfc_index_zero_node);
4723 tmp = fold_build3_loc (input_location, COND_EXPR,
4724 gfc_array_index_type, tmp,
4725 stride, gfc_index_zero_node);
4726 gfc_add_modify (pblock, stride, tmp);
4731 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4733 /* Evaluate non-constant array bound expressions. */
4734 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4735 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4737 gfc_init_se (&se, NULL);
4738 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4739 gfc_add_block_to_block (pblock, &se.pre);
4740 gfc_add_modify (pblock, lbound, se.expr);
4742 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4743 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4745 gfc_init_se (&se, NULL);
4746 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4747 gfc_add_block_to_block (pblock, &se.pre);
4748 gfc_add_modify (pblock, ubound, se.expr);
4751 gfc_trans_vla_type_sizes (sym, pblock);
4758 /* Generate code to initialize/allocate an array variable. */
4761 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4762 gfc_wrapped_block * block)
4766 tree tmp = NULL_TREE;
4773 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4775 /* Do nothing for USEd variables. */
4776 if (sym->attr.use_assoc)
4779 type = TREE_TYPE (decl);
4780 gcc_assert (GFC_ARRAY_TYPE_P (type));
4781 onstack = TREE_CODE (type) != POINTER_TYPE;
4783 gfc_start_block (&init);
4785 /* Evaluate character string length. */
4786 if (sym->ts.type == BT_CHARACTER
4787 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4789 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4791 gfc_trans_vla_type_sizes (sym, &init);
4793 /* Emit a DECL_EXPR for this variable, which will cause the
4794 gimplifier to allocate storage, and all that good stuff. */
4795 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4796 gfc_add_expr_to_block (&init, tmp);
4801 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4805 type = TREE_TYPE (type);
4807 gcc_assert (!sym->attr.use_assoc);
4808 gcc_assert (!TREE_STATIC (decl));
4809 gcc_assert (!sym->module);
4811 if (sym->ts.type == BT_CHARACTER
4812 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4813 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4815 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4817 /* Don't actually allocate space for Cray Pointees. */
4818 if (sym->attr.cray_pointee)
4820 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4821 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4823 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4827 if (gfc_option.flag_stack_arrays)
4829 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
4830 space = build_decl (sym->declared_at.lb->location,
4831 VAR_DECL, create_tmp_var_name ("A"),
4832 TREE_TYPE (TREE_TYPE (decl)));
4833 gfc_trans_vla_type_sizes (sym, &init);
4837 /* The size is the number of elements in the array, so multiply by the
4838 size of an element to get the total size. */
4839 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4840 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4841 size, fold_convert (gfc_array_index_type, tmp));
4843 /* Allocate memory to hold the data. */
4844 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4845 gfc_add_modify (&init, decl, tmp);
4847 /* Free the temporary. */
4848 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4852 /* Set offset of the array. */
4853 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4854 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4856 /* Automatic arrays should not have initializers. */
4857 gcc_assert (!sym->value);
4859 inittree = gfc_finish_block (&init);
4866 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
4867 where also space is located. */
4868 gfc_init_block (&init);
4869 tmp = fold_build1_loc (input_location, DECL_EXPR,
4870 TREE_TYPE (space), space);
4871 gfc_add_expr_to_block (&init, tmp);
4872 addr = fold_build1_loc (sym->declared_at.lb->location,
4873 ADDR_EXPR, TREE_TYPE (decl), space);
4874 gfc_add_modify (&init, decl, addr);
4875 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4878 gfc_add_init_cleanup (block, inittree, tmp);
4882 /* Generate entry and exit code for g77 calling convention arrays. */
4885 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4895 gfc_save_backend_locus (&loc);
4896 gfc_set_backend_locus (&sym->declared_at);
4898 /* Descriptor type. */
4899 parm = sym->backend_decl;
4900 type = TREE_TYPE (parm);
4901 gcc_assert (GFC_ARRAY_TYPE_P (type));
4903 gfc_start_block (&init);
4905 if (sym->ts.type == BT_CHARACTER
4906 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4907 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4909 /* Evaluate the bounds of the array. */
4910 gfc_trans_array_bounds (type, sym, &offset, &init);
4912 /* Set the offset. */
4913 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4914 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4916 /* Set the pointer itself if we aren't using the parameter directly. */
4917 if (TREE_CODE (parm) != PARM_DECL)
4919 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4920 gfc_add_modify (&init, parm, tmp);
4922 stmt = gfc_finish_block (&init);
4924 gfc_restore_backend_locus (&loc);
4926 /* Add the initialization code to the start of the function. */
4928 if (sym->attr.optional || sym->attr.not_always_present)
4930 tmp = gfc_conv_expr_present (sym);
4931 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
4934 gfc_add_init_cleanup (block, stmt, NULL_TREE);
4938 /* Modify the descriptor of an array parameter so that it has the
4939 correct lower bound. Also move the upper bound accordingly.
4940 If the array is not packed, it will be copied into a temporary.
4941 For each dimension we set the new lower and upper bounds. Then we copy the
4942 stride and calculate the offset for this dimension. We also work out
4943 what the stride of a packed array would be, and see it the two match.
4944 If the array need repacking, we set the stride to the values we just
4945 calculated, recalculate the offset and copy the array data.
4946 Code is also added to copy the data back at the end of the function.
4950 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
4951 gfc_wrapped_block * block)
4958 tree stmtInit, stmtCleanup;
4965 tree stride, stride2;
4975 /* Do nothing for pointer and allocatable arrays. */
4976 if (sym->attr.pointer || sym->attr.allocatable)
4979 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
4981 gfc_trans_g77_array (sym, block);
4985 gfc_save_backend_locus (&loc);
4986 gfc_set_backend_locus (&sym->declared_at);
4988 /* Descriptor type. */
4989 type = TREE_TYPE (tmpdesc);
4990 gcc_assert (GFC_ARRAY_TYPE_P (type));
4991 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
4992 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
4993 gfc_start_block (&init);
4995 if (sym->ts.type == BT_CHARACTER
4996 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4997 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4999 checkparm = (sym->as->type == AS_EXPLICIT
5000 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5002 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5003 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5005 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5007 /* For non-constant shape arrays we only check if the first dimension
5008 is contiguous. Repacking higher dimensions wouldn't gain us
5009 anything as we still don't know the array stride. */
5010 partial = gfc_create_var (boolean_type_node, "partial");
5011 TREE_USED (partial) = 1;
5012 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5013 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5014 gfc_index_one_node);
5015 gfc_add_modify (&init, partial, tmp);
5018 partial = NULL_TREE;
5020 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5021 here, however I think it does the right thing. */
5024 /* Set the first stride. */
5025 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5026 stride = gfc_evaluate_now (stride, &init);
5028 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5029 stride, gfc_index_zero_node);
5030 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5031 tmp, gfc_index_one_node, stride);
5032 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5033 gfc_add_modify (&init, stride, tmp);
5035 /* Allow the user to disable array repacking. */
5036 stmt_unpacked = NULL_TREE;
5040 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5041 /* A library call to repack the array if necessary. */
5042 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5043 stmt_unpacked = build_call_expr_loc (input_location,
5044 gfor_fndecl_in_pack, 1, tmp);
5046 stride = gfc_index_one_node;
5048 if (gfc_option.warn_array_temp)
5049 gfc_warning ("Creating array temporary at %L", &loc);
5052 /* This is for the case where the array data is used directly without
5053 calling the repack function. */
5054 if (no_repack || partial != NULL_TREE)
5055 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5057 stmt_packed = NULL_TREE;
5059 /* Assign the data pointer. */
5060 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5062 /* Don't repack unknown shape arrays when the first stride is 1. */
5063 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5064 partial, stmt_packed, stmt_unpacked);
5067 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5068 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5070 offset = gfc_index_zero_node;
5071 size = gfc_index_one_node;
5073 /* Evaluate the bounds of the array. */
5074 for (n = 0; n < sym->as->rank; n++)
5076 if (checkparm || !sym->as->upper[n])
5078 /* Get the bounds of the actual parameter. */
5079 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5080 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5084 dubound = NULL_TREE;
5085 dlbound = NULL_TREE;
5088 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5089 if (!INTEGER_CST_P (lbound))
5091 gfc_init_se (&se, NULL);
5092 gfc_conv_expr_type (&se, sym->as->lower[n],
5093 gfc_array_index_type);
5094 gfc_add_block_to_block (&init, &se.pre);
5095 gfc_add_modify (&init, lbound, se.expr);
5098 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5099 /* Set the desired upper bound. */
5100 if (sym->as->upper[n])
5102 /* We know what we want the upper bound to be. */
5103 if (!INTEGER_CST_P (ubound))
5105 gfc_init_se (&se, NULL);
5106 gfc_conv_expr_type (&se, sym->as->upper[n],
5107 gfc_array_index_type);
5108 gfc_add_block_to_block (&init, &se.pre);
5109 gfc_add_modify (&init, ubound, se.expr);
5112 /* Check the sizes match. */
5115 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5119 temp = fold_build2_loc (input_location, MINUS_EXPR,
5120 gfc_array_index_type, ubound, lbound);
5121 temp = fold_build2_loc (input_location, PLUS_EXPR,
5122 gfc_array_index_type,
5123 gfc_index_one_node, temp);
5124 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5125 gfc_array_index_type, dubound,
5127 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5128 gfc_array_index_type,
5129 gfc_index_one_node, stride2);
5130 tmp = fold_build2_loc (input_location, NE_EXPR,
5131 gfc_array_index_type, temp, stride2);
5132 asprintf (&msg, "Dimension %d of array '%s' has extent "
5133 "%%ld instead of %%ld", n+1, sym->name);
5135 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5136 fold_convert (long_integer_type_node, temp),
5137 fold_convert (long_integer_type_node, stride2));
5144 /* For assumed shape arrays move the upper bound by the same amount
5145 as the lower bound. */
5146 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5147 gfc_array_index_type, dubound, dlbound);
5148 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5149 gfc_array_index_type, tmp, lbound);
5150 gfc_add_modify (&init, ubound, tmp);
5152 /* The offset of this dimension. offset = offset - lbound * stride. */
5153 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5155 offset = fold_build2_loc (input_location, MINUS_EXPR,
5156 gfc_array_index_type, offset, tmp);
5158 /* The size of this dimension, and the stride of the next. */
5159 if (n + 1 < sym->as->rank)
5161 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5163 if (no_repack || partial != NULL_TREE)
5165 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5167 /* Figure out the stride if not a known constant. */
5168 if (!INTEGER_CST_P (stride))
5171 stmt_packed = NULL_TREE;
5174 /* Calculate stride = size * (ubound + 1 - lbound). */
5175 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5176 gfc_array_index_type,
5177 gfc_index_one_node, lbound);
5178 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5179 gfc_array_index_type, ubound, tmp);
5180 size = fold_build2_loc (input_location, MULT_EXPR,
5181 gfc_array_index_type, size, tmp);
5185 /* Assign the stride. */
5186 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5187 tmp = fold_build3_loc (input_location, COND_EXPR,
5188 gfc_array_index_type, partial,
5189 stmt_unpacked, stmt_packed);
5191 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5192 gfc_add_modify (&init, stride, tmp);
5197 stride = GFC_TYPE_ARRAY_SIZE (type);
5199 if (stride && !INTEGER_CST_P (stride))
5201 /* Calculate size = stride * (ubound + 1 - lbound). */
5202 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5203 gfc_array_index_type,
5204 gfc_index_one_node, lbound);
5205 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5206 gfc_array_index_type,
5208 tmp = fold_build2_loc (input_location, MULT_EXPR,
5209 gfc_array_index_type,
5210 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5211 gfc_add_modify (&init, stride, tmp);
5216 /* Set the offset. */
5217 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5218 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5220 gfc_trans_vla_type_sizes (sym, &init);
5222 stmtInit = gfc_finish_block (&init);
5224 /* Only do the entry/initialization code if the arg is present. */
5225 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5226 optional_arg = (sym->attr.optional
5227 || (sym->ns->proc_name->attr.entry_master
5228 && sym->attr.dummy));
5231 tmp = gfc_conv_expr_present (sym);
5232 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5233 build_empty_stmt (input_location));
5238 stmtCleanup = NULL_TREE;
5241 stmtblock_t cleanup;
5242 gfc_start_block (&cleanup);
5244 if (sym->attr.intent != INTENT_IN)
5246 /* Copy the data back. */
5247 tmp = build_call_expr_loc (input_location,
5248 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5249 gfc_add_expr_to_block (&cleanup, tmp);
5252 /* Free the temporary. */
5253 tmp = gfc_call_free (tmpdesc);
5254 gfc_add_expr_to_block (&cleanup, tmp);
5256 stmtCleanup = gfc_finish_block (&cleanup);
5258 /* Only do the cleanup if the array was repacked. */
5259 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5260 tmp = gfc_conv_descriptor_data_get (tmp);
5261 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5263 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5264 build_empty_stmt (input_location));
5268 tmp = gfc_conv_expr_present (sym);
5269 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5270 build_empty_stmt (input_location));
5274 /* We don't need to free any memory allocated by internal_pack as it will
5275 be freed at the end of the function by pop_context. */
5276 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5278 gfc_restore_backend_locus (&loc);
5282 /* Calculate the overall offset, including subreferences. */
5284 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5285 bool subref, gfc_expr *expr)
5295 /* If offset is NULL and this is not a subreferenced array, there is
5297 if (offset == NULL_TREE)
5300 offset = gfc_index_zero_node;
5305 tmp = gfc_conv_array_data (desc);
5306 tmp = build_fold_indirect_ref_loc (input_location,
5308 tmp = gfc_build_array_ref (tmp, offset, NULL);
5310 /* Offset the data pointer for pointer assignments from arrays with
5311 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5314 /* Go past the array reference. */
5315 for (ref = expr->ref; ref; ref = ref->next)
5316 if (ref->type == REF_ARRAY &&
5317 ref->u.ar.type != AR_ELEMENT)
5323 /* Calculate the offset for each subsequent subreference. */
5324 for (; ref; ref = ref->next)
5329 field = ref->u.c.component->backend_decl;
5330 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5331 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5333 tmp, field, NULL_TREE);
5337 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5338 gfc_init_se (&start, NULL);
5339 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5340 gfc_add_block_to_block (block, &start.pre);
5341 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5345 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5346 && ref->u.ar.type == AR_ELEMENT);
5348 /* TODO - Add bounds checking. */
5349 stride = gfc_index_one_node;
5350 index = gfc_index_zero_node;
5351 for (n = 0; n < ref->u.ar.dimen; n++)
5356 /* Update the index. */
5357 gfc_init_se (&start, NULL);
5358 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5359 itmp = gfc_evaluate_now (start.expr, block);
5360 gfc_init_se (&start, NULL);
5361 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5362 jtmp = gfc_evaluate_now (start.expr, block);
5363 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5364 gfc_array_index_type, itmp, jtmp);
5365 itmp = fold_build2_loc (input_location, MULT_EXPR,
5366 gfc_array_index_type, itmp, stride);
5367 index = fold_build2_loc (input_location, PLUS_EXPR,
5368 gfc_array_index_type, itmp, index);
5369 index = gfc_evaluate_now (index, block);
5371 /* Update the stride. */
5372 gfc_init_se (&start, NULL);
5373 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5374 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5375 gfc_array_index_type, start.expr,
5377 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5378 gfc_array_index_type,
5379 gfc_index_one_node, itmp);
5380 stride = fold_build2_loc (input_location, MULT_EXPR,
5381 gfc_array_index_type, stride, itmp);
5382 stride = gfc_evaluate_now (stride, block);
5385 /* Apply the index to obtain the array element. */
5386 tmp = gfc_build_array_ref (tmp, index, NULL);
5396 /* Set the target data pointer. */
5397 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5398 gfc_conv_descriptor_data_set (block, parm, offset);
5402 /* gfc_conv_expr_descriptor needs the string length an expression
5403 so that the size of the temporary can be obtained. This is done
5404 by adding up the string lengths of all the elements in the
5405 expression. Function with non-constant expressions have their
5406 string lengths mapped onto the actual arguments using the
5407 interface mapping machinery in trans-expr.c. */
5409 get_array_charlen (gfc_expr *expr, gfc_se *se)
5411 gfc_interface_mapping mapping;
5412 gfc_formal_arglist *formal;
5413 gfc_actual_arglist *arg;
5416 if (expr->ts.u.cl->length
5417 && gfc_is_constant_expr (expr->ts.u.cl->length))
5419 if (!expr->ts.u.cl->backend_decl)
5420 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5424 switch (expr->expr_type)
5427 get_array_charlen (expr->value.op.op1, se);
5429 /* For parentheses the expression ts.u.cl is identical. */
5430 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5433 expr->ts.u.cl->backend_decl =
5434 gfc_create_var (gfc_charlen_type_node, "sln");
5436 if (expr->value.op.op2)
5438 get_array_charlen (expr->value.op.op2, se);
5440 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5442 /* Add the string lengths and assign them to the expression
5443 string length backend declaration. */
5444 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5445 fold_build2_loc (input_location, PLUS_EXPR,
5446 gfc_charlen_type_node,
5447 expr->value.op.op1->ts.u.cl->backend_decl,
5448 expr->value.op.op2->ts.u.cl->backend_decl));
5451 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5452 expr->value.op.op1->ts.u.cl->backend_decl);
5456 if (expr->value.function.esym == NULL
5457 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5459 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5463 /* Map expressions involving the dummy arguments onto the actual
5464 argument expressions. */
5465 gfc_init_interface_mapping (&mapping);
5466 formal = expr->symtree->n.sym->formal;
5467 arg = expr->value.function.actual;
5469 /* Set se = NULL in the calls to the interface mapping, to suppress any
5471 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5476 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5479 gfc_init_se (&tse, NULL);
5481 /* Build the expression for the character length and convert it. */
5482 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5484 gfc_add_block_to_block (&se->pre, &tse.pre);
5485 gfc_add_block_to_block (&se->post, &tse.post);
5486 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5487 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5488 gfc_charlen_type_node, tse.expr,
5489 build_int_cst (gfc_charlen_type_node, 0));
5490 expr->ts.u.cl->backend_decl = tse.expr;
5491 gfc_free_interface_mapping (&mapping);
5495 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5500 /* Helper function to check dimensions. */
5502 dim_ok (gfc_ss_info *info)
5505 for (n = 0; n < info->dimen; n++)
5506 if (info->dim[n] != n)
5511 /* Convert an array for passing as an actual argument. Expressions and
5512 vector subscripts are evaluated and stored in a temporary, which is then
5513 passed. For whole arrays the descriptor is passed. For array sections
5514 a modified copy of the descriptor is passed, but using the original data.
5516 This function is also used for array pointer assignments, and there
5519 - se->want_pointer && !se->direct_byref
5520 EXPR is an actual argument. On exit, se->expr contains a
5521 pointer to the array descriptor.
5523 - !se->want_pointer && !se->direct_byref
5524 EXPR is an actual argument to an intrinsic function or the
5525 left-hand side of a pointer assignment. On exit, se->expr
5526 contains the descriptor for EXPR.
5528 - !se->want_pointer && se->direct_byref
5529 EXPR is the right-hand side of a pointer assignment and
5530 se->expr is the descriptor for the previously-evaluated
5531 left-hand side. The function creates an assignment from
5535 The se->force_tmp flag disables the non-copying descriptor optimization
5536 that is used for transpose. It may be used in cases where there is an
5537 alias between the transpose argument and another argument in the same
5541 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5553 bool subref_array_target = false;
5556 gcc_assert (ss != NULL);
5557 gcc_assert (ss != gfc_ss_terminator);
5559 /* Special case things we know we can pass easily. */
5560 switch (expr->expr_type)
5563 /* If we have a linear array section, we can pass it directly.
5564 Otherwise we need to copy it into a temporary. */
5566 gcc_assert (ss->type == GFC_SS_SECTION);
5567 gcc_assert (ss->expr == expr);
5568 info = &ss->data.info;
5570 /* Get the descriptor for the array. */
5571 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5572 desc = info->descriptor;
5574 subref_array_target = se->direct_byref && is_subref_array (expr);
5575 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5576 && !subref_array_target;
5583 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5585 /* Create a new descriptor if the array doesn't have one. */
5588 else if (info->ref->u.ar.type == AR_FULL)
5590 else if (se->direct_byref)
5593 full = gfc_full_array_ref_p (info->ref, NULL);
5595 if (full && dim_ok (info))
5597 if (se->direct_byref && !se->byref_noassign)
5599 /* Copy the descriptor for pointer assignments. */
5600 gfc_add_modify (&se->pre, se->expr, desc);
5602 /* Add any offsets from subreferences. */
5603 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5604 subref_array_target, expr);
5606 else if (se->want_pointer)
5608 /* We pass full arrays directly. This means that pointers and
5609 allocatable arrays should also work. */
5610 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5617 if (expr->ts.type == BT_CHARACTER)
5618 se->string_length = gfc_get_expr_charlen (expr);
5626 /* We don't need to copy data in some cases. */
5627 arg = gfc_get_noncopying_intrinsic_argument (expr);
5630 /* This is a call to transpose... */
5631 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5632 /* ... which has already been handled by the scalarizer, so
5633 that we just need to get its argument's descriptor. */
5634 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5638 /* A transformational function return value will be a temporary
5639 array descriptor. We still need to go through the scalarizer
5640 to create the descriptor. Elemental functions ar handled as
5641 arbitrary expressions, i.e. copy to a temporary. */
5643 if (se->direct_byref)
5645 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5647 /* For pointer assignments pass the descriptor directly. */
5651 gcc_assert (se->ss == ss);
5652 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5653 gfc_conv_expr (se, expr);
5657 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5659 if (ss->expr != expr)
5660 /* Elemental function. */
5661 gcc_assert ((expr->value.function.esym != NULL
5662 && expr->value.function.esym->attr.elemental)
5663 || (expr->value.function.isym != NULL
5664 && expr->value.function.isym->elemental));
5666 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5669 if (expr->ts.type == BT_CHARACTER
5670 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5671 get_array_charlen (expr, se);
5677 /* Transformational function. */
5678 info = &ss->data.info;
5684 /* Constant array constructors don't need a temporary. */
5685 if (ss->type == GFC_SS_CONSTRUCTOR
5686 && expr->ts.type != BT_CHARACTER
5687 && gfc_constant_array_constructor_p (expr->value.constructor))
5690 info = &ss->data.info;
5700 /* Something complicated. Copy it into a temporary. */
5706 /* If we are creating a temporary, we don't need to bother about aliases
5711 gfc_init_loopinfo (&loop);
5713 /* Associate the SS with the loop. */
5714 gfc_add_ss_to_loop (&loop, ss);
5716 /* Tell the scalarizer not to bother creating loop variables, etc. */
5718 loop.array_parameter = 1;
5720 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5721 gcc_assert (!se->direct_byref);
5723 /* Setup the scalarizing loops and bounds. */
5724 gfc_conv_ss_startstride (&loop);
5728 /* Tell the scalarizer to make a temporary. */
5729 loop.temp_ss = gfc_get_ss ();
5730 loop.temp_ss->type = GFC_SS_TEMP;
5731 loop.temp_ss->next = gfc_ss_terminator;
5733 if (expr->ts.type == BT_CHARACTER
5734 && !expr->ts.u.cl->backend_decl)
5735 get_array_charlen (expr, se);
5737 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5739 if (expr->ts.type == BT_CHARACTER)
5740 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5742 loop.temp_ss->string_length = NULL;
5744 se->string_length = loop.temp_ss->string_length;
5745 loop.temp_ss->data.temp.dimen = loop.dimen;
5746 loop.temp_ss->data.temp.codimen = loop.codimen;
5747 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5750 gfc_conv_loop_setup (&loop, & expr->where);
5754 /* Copy into a temporary and pass that. We don't need to copy the data
5755 back because expressions and vector subscripts must be INTENT_IN. */
5756 /* TODO: Optimize passing function return values. */
5760 /* Start the copying loops. */
5761 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5762 gfc_mark_ss_chain_used (ss, 1);
5763 gfc_start_scalarized_body (&loop, &block);
5765 /* Copy each data element. */
5766 gfc_init_se (&lse, NULL);
5767 gfc_copy_loopinfo_to_se (&lse, &loop);
5768 gfc_init_se (&rse, NULL);
5769 gfc_copy_loopinfo_to_se (&rse, &loop);
5771 lse.ss = loop.temp_ss;
5774 gfc_conv_scalarized_array_ref (&lse, NULL);
5775 if (expr->ts.type == BT_CHARACTER)
5777 gfc_conv_expr (&rse, expr);
5778 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5779 rse.expr = build_fold_indirect_ref_loc (input_location,
5783 gfc_conv_expr_val (&rse, expr);
5785 gfc_add_block_to_block (&block, &rse.pre);
5786 gfc_add_block_to_block (&block, &lse.pre);
5788 lse.string_length = rse.string_length;
5789 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5790 expr->expr_type == EXPR_VARIABLE, true);
5791 gfc_add_expr_to_block (&block, tmp);
5793 /* Finish the copying loops. */
5794 gfc_trans_scalarizing_loops (&loop, &block);
5796 desc = loop.temp_ss->data.info.descriptor;
5798 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5800 desc = info->descriptor;
5801 se->string_length = ss->string_length;
5805 /* We pass sections without copying to a temporary. Make a new
5806 descriptor and point it at the section we want. The loop variable
5807 limits will be the limits of the section.
5808 A function may decide to repack the array to speed up access, but
5809 we're not bothered about that here. */
5810 int dim, ndim, codim;
5818 /* Set the string_length for a character array. */
5819 if (expr->ts.type == BT_CHARACTER)
5820 se->string_length = gfc_get_expr_charlen (expr);
5822 desc = info->descriptor;
5823 if (se->direct_byref && !se->byref_noassign)
5825 /* For pointer assignments we fill in the destination. */
5827 parmtype = TREE_TYPE (parm);
5831 /* Otherwise make a new one. */
5832 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5833 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5834 loop.codimen, loop.from,
5836 GFC_ARRAY_UNKNOWN, false);
5837 parm = gfc_create_var (parmtype, "parm");
5840 offset = gfc_index_zero_node;
5842 /* The following can be somewhat confusing. We have two
5843 descriptors, a new one and the original array.
5844 {parm, parmtype, dim} refer to the new one.
5845 {desc, type, n, loop} refer to the original, which maybe
5846 a descriptorless array.
5847 The bounds of the scalarization are the bounds of the section.
5848 We don't have to worry about numeric overflows when calculating
5849 the offsets because all elements are within the array data. */
5851 /* Set the dtype. */
5852 tmp = gfc_conv_descriptor_dtype (parm);
5853 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5855 /* Set offset for assignments to pointer only to zero if it is not
5857 if (se->direct_byref
5858 && info->ref && info->ref->u.ar.type != AR_FULL)
5859 base = gfc_index_zero_node;
5860 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5861 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5865 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5866 codim = info->codimen;
5867 for (n = 0; n < ndim; n++)
5869 stride = gfc_conv_array_stride (desc, n);
5871 /* Work out the offset. */
5873 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5875 gcc_assert (info->subscript[n]
5876 && info->subscript[n]->type == GFC_SS_SCALAR);
5877 start = info->subscript[n]->data.scalar.expr;
5881 /* Evaluate and remember the start of the section. */
5882 start = info->start[n];
5883 stride = gfc_evaluate_now (stride, &loop.pre);
5886 tmp = gfc_conv_array_lbound (desc, n);
5887 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5889 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5891 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5895 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5897 /* For elemental dimensions, we only need the offset. */
5901 /* Vector subscripts need copying and are handled elsewhere. */
5903 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5905 /* look for the corresponding scalarizer dimension: dim. */
5906 for (dim = 0; dim < ndim; dim++)
5907 if (info->dim[dim] == n)
5910 /* loop exited early: the DIM being looked for has been found. */
5911 gcc_assert (dim < ndim);
5913 /* Set the new lower bound. */
5914 from = loop.from[dim];
5917 /* If we have an array section or are assigning make sure that
5918 the lower bound is 1. References to the full
5919 array should otherwise keep the original bounds. */
5921 || info->ref->u.ar.type != AR_FULL)
5922 && !integer_onep (from))
5924 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5925 gfc_array_index_type, gfc_index_one_node,
5927 to = fold_build2_loc (input_location, PLUS_EXPR,
5928 gfc_array_index_type, to, tmp);
5929 from = gfc_index_one_node;
5931 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5932 gfc_rank_cst[dim], from);
5934 /* Set the new upper bound. */
5935 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5936 gfc_rank_cst[dim], to);
5938 /* Multiply the stride by the section stride to get the
5940 stride = fold_build2_loc (input_location, MULT_EXPR,
5941 gfc_array_index_type,
5942 stride, info->stride[n]);
5944 if (se->direct_byref
5946 && info->ref->u.ar.type != AR_FULL)
5948 base = fold_build2_loc (input_location, MINUS_EXPR,
5949 TREE_TYPE (base), base, stride);
5951 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5953 tmp = gfc_conv_array_lbound (desc, n);
5954 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5955 TREE_TYPE (base), tmp, loop.from[dim]);
5956 tmp = fold_build2_loc (input_location, MULT_EXPR,
5957 TREE_TYPE (base), tmp,
5958 gfc_conv_array_stride (desc, n));
5959 base = fold_build2_loc (input_location, PLUS_EXPR,
5960 TREE_TYPE (base), tmp, base);
5963 /* Store the new stride. */
5964 gfc_conv_descriptor_stride_set (&loop.pre, parm,
5965 gfc_rank_cst[dim], stride);
5968 for (n = ndim; n < ndim + codim; n++)
5970 /* look for the corresponding scalarizer dimension: dim. */
5971 for (dim = 0; dim < ndim + codim; dim++)
5972 if (info->dim[dim] == n)
5975 /* loop exited early: the DIM being looked for has been found. */
5976 gcc_assert (dim < ndim + codim);
5978 from = loop.from[dim];
5980 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
5981 gfc_rank_cst[dim], from);
5982 if (n < ndim + codim - 1)
5983 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
5984 gfc_rank_cst[dim], to);
5988 if (se->data_not_needed)
5989 gfc_conv_descriptor_data_set (&loop.pre, parm,
5990 gfc_index_zero_node);
5992 /* Point the data pointer at the 1st element in the section. */
5993 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
5994 subref_array_target, expr);
5996 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5997 && !se->data_not_needed)
5999 /* Set the offset. */
6000 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6004 /* Only the callee knows what the correct offset it, so just set
6006 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6011 if (!se->direct_byref || se->byref_noassign)
6013 /* Get a pointer to the new descriptor. */
6014 if (se->want_pointer)
6015 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6020 gfc_add_block_to_block (&se->pre, &loop.pre);
6021 gfc_add_block_to_block (&se->post, &loop.post);
6023 /* Cleanup the scalarizer. */
6024 gfc_cleanup_loop (&loop);
6027 /* Helper function for gfc_conv_array_parameter if array size needs to be
6031 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6034 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6035 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6036 else if (expr->rank > 1)
6037 *size = build_call_expr_loc (input_location,
6038 gfor_fndecl_size0, 1,
6039 gfc_build_addr_expr (NULL, desc));
6042 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6043 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6045 *size = fold_build2_loc (input_location, MINUS_EXPR,
6046 gfc_array_index_type, ubound, lbound);
6047 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6048 *size, gfc_index_one_node);
6049 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6050 *size, gfc_index_zero_node);
6052 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6053 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6054 *size, fold_convert (gfc_array_index_type, elem));
6057 /* Convert an array for passing as an actual parameter. */
6058 /* TODO: Optimize passing g77 arrays. */
6061 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6062 const gfc_symbol *fsym, const char *proc_name,
6067 tree tmp = NULL_TREE;
6069 tree parent = DECL_CONTEXT (current_function_decl);
6070 bool full_array_var;
6071 bool this_array_result;
6074 bool array_constructor;
6075 bool good_allocatable;
6076 bool ultimate_ptr_comp;
6077 bool ultimate_alloc_comp;
6082 ultimate_ptr_comp = false;
6083 ultimate_alloc_comp = false;
6085 for (ref = expr->ref; ref; ref = ref->next)
6087 if (ref->next == NULL)
6090 if (ref->type == REF_COMPONENT)
6092 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6093 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6097 full_array_var = false;
6100 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6101 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6103 sym = full_array_var ? expr->symtree->n.sym : NULL;
6105 /* The symbol should have an array specification. */
6106 gcc_assert (!sym || sym->as || ref->u.ar.as);
6108 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6110 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6111 expr->ts.u.cl->backend_decl = tmp;
6112 se->string_length = tmp;
6115 /* Is this the result of the enclosing procedure? */
6116 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6117 if (this_array_result
6118 && (sym->backend_decl != current_function_decl)
6119 && (sym->backend_decl != parent))
6120 this_array_result = false;
6122 /* Passing address of the array if it is not pointer or assumed-shape. */
6123 if (full_array_var && g77 && !this_array_result)
6125 tmp = gfc_get_symbol_decl (sym);
6127 if (sym->ts.type == BT_CHARACTER)
6128 se->string_length = sym->ts.u.cl->backend_decl;
6130 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6132 gfc_conv_expr_descriptor (se, expr, ss);
6133 se->expr = gfc_conv_array_data (se->expr);
6137 if (!sym->attr.pointer
6139 && sym->as->type != AS_ASSUMED_SHAPE
6140 && !sym->attr.allocatable)
6142 /* Some variables are declared directly, others are declared as
6143 pointers and allocated on the heap. */
6144 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6147 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6149 array_parameter_size (tmp, expr, size);
6153 if (sym->attr.allocatable)
6155 if (sym->attr.dummy || sym->attr.result)
6157 gfc_conv_expr_descriptor (se, expr, ss);
6161 array_parameter_size (tmp, expr, size);
6162 se->expr = gfc_conv_array_data (tmp);
6167 /* A convenient reduction in scope. */
6168 contiguous = g77 && !this_array_result && contiguous;
6170 /* There is no need to pack and unpack the array, if it is contiguous
6171 and not a deferred- or assumed-shape array, or if it is simply
6173 no_pack = ((sym && sym->as
6174 && !sym->attr.pointer
6175 && sym->as->type != AS_DEFERRED
6176 && sym->as->type != AS_ASSUMED_SHAPE)
6178 (ref && ref->u.ar.as
6179 && ref->u.ar.as->type != AS_DEFERRED
6180 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6182 gfc_is_simply_contiguous (expr, false));
6184 no_pack = contiguous && no_pack;
6186 /* Array constructors are always contiguous and do not need packing. */
6187 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6189 /* Same is true of contiguous sections from allocatable variables. */
6190 good_allocatable = contiguous
6192 && expr->symtree->n.sym->attr.allocatable;
6194 /* Or ultimate allocatable components. */
6195 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6197 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6199 gfc_conv_expr_descriptor (se, expr, ss);
6200 if (expr->ts.type == BT_CHARACTER)
6201 se->string_length = expr->ts.u.cl->backend_decl;
6203 array_parameter_size (se->expr, expr, size);
6204 se->expr = gfc_conv_array_data (se->expr);
6208 if (this_array_result)
6210 /* Result of the enclosing function. */
6211 gfc_conv_expr_descriptor (se, expr, ss);
6213 array_parameter_size (se->expr, expr, size);
6214 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6216 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6217 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6218 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6225 /* Every other type of array. */
6226 se->want_pointer = 1;
6227 gfc_conv_expr_descriptor (se, expr, ss);
6229 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6234 /* Deallocate the allocatable components of structures that are
6236 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6237 && expr->ts.u.derived->attr.alloc_comp
6238 && expr->expr_type != EXPR_VARIABLE)
6240 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6241 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6243 /* The components shall be deallocated before their containing entity. */
6244 gfc_prepend_expr_to_block (&se->post, tmp);
6247 if (g77 || (fsym && fsym->attr.contiguous
6248 && !gfc_is_simply_contiguous (expr, false)))
6250 tree origptr = NULL_TREE;
6254 /* For contiguous arrays, save the original value of the descriptor. */
6257 origptr = gfc_create_var (pvoid_type_node, "origptr");
6258 tmp = build_fold_indirect_ref_loc (input_location, desc);
6259 tmp = gfc_conv_array_data (tmp);
6260 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6261 TREE_TYPE (origptr), origptr,
6262 fold_convert (TREE_TYPE (origptr), tmp));
6263 gfc_add_expr_to_block (&se->pre, tmp);
6266 /* Repack the array. */
6267 if (gfc_option.warn_array_temp)
6270 gfc_warning ("Creating array temporary at %L for argument '%s'",
6271 &expr->where, fsym->name);
6273 gfc_warning ("Creating array temporary at %L", &expr->where);
6276 ptr = build_call_expr_loc (input_location,
6277 gfor_fndecl_in_pack, 1, desc);
6279 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6281 tmp = gfc_conv_expr_present (sym);
6282 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6283 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6284 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6287 ptr = gfc_evaluate_now (ptr, &se->pre);
6289 /* Use the packed data for the actual argument, except for contiguous arrays,
6290 where the descriptor's data component is set. */
6295 tmp = build_fold_indirect_ref_loc (input_location, desc);
6296 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6299 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6303 if (fsym && proc_name)
6304 asprintf (&msg, "An array temporary was created for argument "
6305 "'%s' of procedure '%s'", fsym->name, proc_name);
6307 asprintf (&msg, "An array temporary was created");
6309 tmp = build_fold_indirect_ref_loc (input_location,
6311 tmp = gfc_conv_array_data (tmp);
6312 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6313 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6315 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6316 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6318 gfc_conv_expr_present (sym), tmp);
6320 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6325 gfc_start_block (&block);
6327 /* Copy the data back. */
6328 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6330 tmp = build_call_expr_loc (input_location,
6331 gfor_fndecl_in_unpack, 2, desc, ptr);
6332 gfc_add_expr_to_block (&block, tmp);
6335 /* Free the temporary. */
6336 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6337 gfc_add_expr_to_block (&block, tmp);
6339 stmt = gfc_finish_block (&block);
6341 gfc_init_block (&block);
6342 /* Only if it was repacked. This code needs to be executed before the
6343 loop cleanup code. */
6344 tmp = build_fold_indirect_ref_loc (input_location,
6346 tmp = gfc_conv_array_data (tmp);
6347 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6348 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6350 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6351 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6353 gfc_conv_expr_present (sym), tmp);
6355 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6357 gfc_add_expr_to_block (&block, tmp);
6358 gfc_add_block_to_block (&block, &se->post);
6360 gfc_init_block (&se->post);
6362 /* Reset the descriptor pointer. */
6365 tmp = build_fold_indirect_ref_loc (input_location, desc);
6366 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6369 gfc_add_block_to_block (&se->post, &block);
6374 /* Generate code to deallocate an array, if it is allocated. */
6377 gfc_trans_dealloc_allocated (tree descriptor)
6383 gfc_start_block (&block);
6385 var = gfc_conv_descriptor_data_get (descriptor);
6388 /* Call array_deallocate with an int * present in the second argument.
6389 Although it is ignored here, it's presence ensures that arrays that
6390 are already deallocated are ignored. */
6391 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6392 gfc_add_expr_to_block (&block, tmp);
6394 /* Zero the data pointer. */
6395 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6396 var, build_int_cst (TREE_TYPE (var), 0));
6397 gfc_add_expr_to_block (&block, tmp);
6399 return gfc_finish_block (&block);
6403 /* This helper function calculates the size in words of a full array. */
6406 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6411 idx = gfc_rank_cst[rank - 1];
6412 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6413 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6414 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6416 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6417 tmp, gfc_index_one_node);
6418 tmp = gfc_evaluate_now (tmp, block);
6420 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6421 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6423 return gfc_evaluate_now (tmp, block);
6427 /* Allocate dest to the same size as src, and copy src -> dest.
6428 If no_malloc is set, only the copy is done. */
6431 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6441 /* If the source is null, set the destination to null. Then,
6442 allocate memory to the destination. */
6443 gfc_init_block (&block);
6447 tmp = null_pointer_node;
6448 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6449 gfc_add_expr_to_block (&block, tmp);
6450 null_data = gfc_finish_block (&block);
6452 gfc_init_block (&block);
6453 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6456 tmp = gfc_call_malloc (&block, type, size);
6457 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6458 dest, fold_convert (type, tmp));
6459 gfc_add_expr_to_block (&block, tmp);
6462 tmp = built_in_decls[BUILT_IN_MEMCPY];
6463 tmp = build_call_expr_loc (input_location, tmp, 3,
6468 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6469 null_data = gfc_finish_block (&block);
6471 gfc_init_block (&block);
6472 nelems = get_full_array_size (&block, src, rank);
6473 tmp = fold_convert (gfc_array_index_type,
6474 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6475 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6479 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6480 tmp = gfc_call_malloc (&block, tmp, size);
6481 gfc_conv_descriptor_data_set (&block, dest, tmp);
6484 /* We know the temporary and the value will be the same length,
6485 so can use memcpy. */
6486 tmp = built_in_decls[BUILT_IN_MEMCPY];
6487 tmp = build_call_expr_loc (input_location,
6488 tmp, 3, gfc_conv_descriptor_data_get (dest),
6489 gfc_conv_descriptor_data_get (src), size);
6492 gfc_add_expr_to_block (&block, tmp);
6493 tmp = gfc_finish_block (&block);
6495 /* Null the destination if the source is null; otherwise do
6496 the allocate and copy. */
6500 null_cond = gfc_conv_descriptor_data_get (src);
6502 null_cond = convert (pvoid_type_node, null_cond);
6503 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6504 null_cond, null_pointer_node);
6505 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6509 /* Allocate dest to the same size as src, and copy data src -> dest. */
6512 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6514 return duplicate_allocatable (dest, src, type, rank, false);
6518 /* Copy data src -> dest. */
6521 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6523 return duplicate_allocatable (dest, src, type, rank, true);
6527 /* Recursively traverse an object of derived type, generating code to
6528 deallocate, nullify or copy allocatable components. This is the work horse
6529 function for the functions named in this enum. */
6531 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6532 COPY_ONLY_ALLOC_COMP};
6535 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6536 tree dest, int rank, int purpose)
6540 stmtblock_t fnblock;
6541 stmtblock_t loopbody;
6552 tree null_cond = NULL_TREE;
6554 gfc_init_block (&fnblock);
6556 decl_type = TREE_TYPE (decl);
6558 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6559 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6561 decl = build_fold_indirect_ref_loc (input_location,
6564 /* Just in case in gets dereferenced. */
6565 decl_type = TREE_TYPE (decl);
6567 /* If this an array of derived types with allocatable components
6568 build a loop and recursively call this function. */
6569 if (TREE_CODE (decl_type) == ARRAY_TYPE
6570 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6572 tmp = gfc_conv_array_data (decl);
6573 var = build_fold_indirect_ref_loc (input_location,
6576 /* Get the number of elements - 1 and set the counter. */
6577 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6579 /* Use the descriptor for an allocatable array. Since this
6580 is a full array reference, we only need the descriptor
6581 information from dimension = rank. */
6582 tmp = get_full_array_size (&fnblock, decl, rank);
6583 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6584 gfc_array_index_type, tmp,
6585 gfc_index_one_node);
6587 null_cond = gfc_conv_descriptor_data_get (decl);
6588 null_cond = fold_build2_loc (input_location, NE_EXPR,
6589 boolean_type_node, null_cond,
6590 build_int_cst (TREE_TYPE (null_cond), 0));
6594 /* Otherwise use the TYPE_DOMAIN information. */
6595 tmp = array_type_nelts (decl_type);
6596 tmp = fold_convert (gfc_array_index_type, tmp);
6599 /* Remember that this is, in fact, the no. of elements - 1. */
6600 nelems = gfc_evaluate_now (tmp, &fnblock);
6601 index = gfc_create_var (gfc_array_index_type, "S");
6603 /* Build the body of the loop. */
6604 gfc_init_block (&loopbody);
6606 vref = gfc_build_array_ref (var, index, NULL);
6608 if (purpose == COPY_ALLOC_COMP)
6610 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6612 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6613 gfc_add_expr_to_block (&fnblock, tmp);
6615 tmp = build_fold_indirect_ref_loc (input_location,
6616 gfc_conv_array_data (dest));
6617 dref = gfc_build_array_ref (tmp, index, NULL);
6618 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6620 else if (purpose == COPY_ONLY_ALLOC_COMP)
6622 tmp = build_fold_indirect_ref_loc (input_location,
6623 gfc_conv_array_data (dest));
6624 dref = gfc_build_array_ref (tmp, index, NULL);
6625 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6629 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6631 gfc_add_expr_to_block (&loopbody, tmp);
6633 /* Build the loop and return. */
6634 gfc_init_loopinfo (&loop);
6636 loop.from[0] = gfc_index_zero_node;
6637 loop.loopvar[0] = index;
6638 loop.to[0] = nelems;
6639 gfc_trans_scalarizing_loops (&loop, &loopbody);
6640 gfc_add_block_to_block (&fnblock, &loop.pre);
6642 tmp = gfc_finish_block (&fnblock);
6643 if (null_cond != NULL_TREE)
6644 tmp = build3_v (COND_EXPR, null_cond, tmp,
6645 build_empty_stmt (input_location));
6650 /* Otherwise, act on the components or recursively call self to
6651 act on a chain of components. */
6652 for (c = der_type->components; c; c = c->next)
6654 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6655 || c->ts.type == BT_CLASS)
6656 && c->ts.u.derived->attr.alloc_comp;
6657 cdecl = c->backend_decl;
6658 ctype = TREE_TYPE (cdecl);
6662 case DEALLOCATE_ALLOC_COMP:
6663 if (c->attr.allocatable && c->attr.dimension)
6665 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6666 decl, cdecl, NULL_TREE);
6667 if (cmp_has_alloc_comps && !c->attr.pointer)
6669 /* Do not deallocate the components of ultimate pointer
6671 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6672 c->as->rank, purpose);
6673 gfc_add_expr_to_block (&fnblock, tmp);
6675 tmp = gfc_trans_dealloc_allocated (comp);
6676 gfc_add_expr_to_block (&fnblock, tmp);
6678 else if (c->attr.allocatable)
6680 /* Allocatable scalar components. */
6681 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6682 decl, cdecl, NULL_TREE);
6684 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6686 gfc_add_expr_to_block (&fnblock, tmp);
6688 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6689 void_type_node, comp,
6690 build_int_cst (TREE_TYPE (comp), 0));
6691 gfc_add_expr_to_block (&fnblock, tmp);
6693 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6695 /* Allocatable scalar CLASS components. */
6696 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6697 decl, cdecl, NULL_TREE);
6699 /* Add reference to '_data' component. */
6700 tmp = CLASS_DATA (c)->backend_decl;
6701 comp = fold_build3_loc (input_location, COMPONENT_REF,
6702 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6704 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6705 CLASS_DATA (c)->ts);
6706 gfc_add_expr_to_block (&fnblock, tmp);
6708 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6709 void_type_node, comp,
6710 build_int_cst (TREE_TYPE (comp), 0));
6711 gfc_add_expr_to_block (&fnblock, tmp);
6715 case NULLIFY_ALLOC_COMP:
6716 if (c->attr.pointer)
6718 else if (c->attr.allocatable && c->attr.dimension)
6720 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6721 decl, cdecl, NULL_TREE);
6722 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6724 else if (c->attr.allocatable)
6726 /* Allocatable scalar components. */
6727 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6728 decl, cdecl, NULL_TREE);
6729 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6730 void_type_node, comp,
6731 build_int_cst (TREE_TYPE (comp), 0));
6732 gfc_add_expr_to_block (&fnblock, tmp);
6734 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6736 /* Allocatable scalar CLASS components. */
6737 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6738 decl, cdecl, NULL_TREE);
6739 /* Add reference to '_data' component. */
6740 tmp = CLASS_DATA (c)->backend_decl;
6741 comp = fold_build3_loc (input_location, COMPONENT_REF,
6742 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6743 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6744 void_type_node, comp,
6745 build_int_cst (TREE_TYPE (comp), 0));
6746 gfc_add_expr_to_block (&fnblock, tmp);
6748 else if (cmp_has_alloc_comps)
6750 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6751 decl, cdecl, NULL_TREE);
6752 rank = c->as ? c->as->rank : 0;
6753 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6755 gfc_add_expr_to_block (&fnblock, tmp);
6759 case COPY_ALLOC_COMP:
6760 if (c->attr.pointer)
6763 /* We need source and destination components. */
6764 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6766 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6768 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6770 if (c->attr.allocatable && !cmp_has_alloc_comps)
6772 rank = c->as ? c->as->rank : 0;
6773 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6774 gfc_add_expr_to_block (&fnblock, tmp);
6777 if (cmp_has_alloc_comps)
6779 rank = c->as ? c->as->rank : 0;
6780 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6781 gfc_add_modify (&fnblock, dcmp, tmp);
6782 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6784 gfc_add_expr_to_block (&fnblock, tmp);
6794 return gfc_finish_block (&fnblock);
6797 /* Recursively traverse an object of derived type, generating code to
6798 nullify allocatable components. */
6801 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6803 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6804 NULLIFY_ALLOC_COMP);
6808 /* Recursively traverse an object of derived type, generating code to
6809 deallocate allocatable components. */
6812 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6814 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6815 DEALLOCATE_ALLOC_COMP);
6819 /* Recursively traverse an object of derived type, generating code to
6820 copy it and its allocatable components. */
6823 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6825 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6829 /* Recursively traverse an object of derived type, generating code to
6830 copy only its allocatable components. */
6833 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6835 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6839 /* Returns the value of LBOUND for an expression. This could be broken out
6840 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6841 called by gfc_alloc_allocatable_for_assignment. */
6843 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6848 tree cond, cond1, cond3, cond4;
6852 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6854 tmp = gfc_rank_cst[dim];
6855 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6856 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6857 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6858 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6860 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6861 stride, gfc_index_zero_node);
6862 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6863 boolean_type_node, cond3, cond1);
6864 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6865 stride, gfc_index_zero_node);
6867 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6868 tmp, build_int_cst (gfc_array_index_type,
6871 cond = boolean_false_node;
6873 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6874 boolean_type_node, cond3, cond4);
6875 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6876 boolean_type_node, cond, cond1);
6878 return fold_build3_loc (input_location, COND_EXPR,
6879 gfc_array_index_type, cond,
6880 lbound, gfc_index_one_node);
6882 else if (expr->expr_type == EXPR_VARIABLE)
6884 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6885 for (ref = expr->ref; ref; ref = ref->next)
6887 if (ref->type == REF_COMPONENT
6888 && ref->u.c.component->as
6890 && ref->next->u.ar.type == AR_FULL)
6891 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
6893 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
6895 else if (expr->expr_type == EXPR_FUNCTION)
6897 /* A conversion function, so use the argument. */
6898 expr = expr->value.function.actual->expr;
6899 if (expr->expr_type != EXPR_VARIABLE)
6900 return gfc_index_one_node;
6901 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6902 return get_std_lbound (expr, desc, dim, assumed_size);
6905 return gfc_index_one_node;
6909 /* Returns true if an expression represents an lhs that can be reallocated
6913 gfc_is_reallocatable_lhs (gfc_expr *expr)
6920 /* An allocatable variable. */
6921 if (expr->symtree->n.sym->attr.allocatable
6923 && expr->ref->type == REF_ARRAY
6924 && expr->ref->u.ar.type == AR_FULL)
6927 /* All that can be left are allocatable components. */
6928 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
6929 && expr->symtree->n.sym->ts.type != BT_CLASS)
6930 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
6933 /* Find a component ref followed by an array reference. */
6934 for (ref = expr->ref; ref; ref = ref->next)
6936 && ref->type == REF_COMPONENT
6937 && ref->next->type == REF_ARRAY
6938 && !ref->next->next)
6944 /* Return true if valid reallocatable lhs. */
6945 if (ref->u.c.component->attr.allocatable
6946 && ref->next->u.ar.type == AR_FULL)
6953 /* Allocate the lhs of an assignment to an allocatable array, otherwise
6957 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
6961 stmtblock_t realloc_block;
6962 stmtblock_t alloc_block;
6985 gfc_array_spec * as;
6987 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
6988 Find the lhs expression in the loop chain and set expr1 and
6989 expr2 accordingly. */
6990 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
6993 /* Find the ss for the lhs. */
6995 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
6996 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
6998 if (lss == gfc_ss_terminator)
7003 /* Bail out if this is not a valid allocate on assignment. */
7004 if (!gfc_is_reallocatable_lhs (expr1)
7005 || (expr2 && !expr2->rank))
7008 /* Find the ss for the lhs. */
7010 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7011 if (lss->expr == expr1)
7014 if (lss == gfc_ss_terminator)
7017 /* Find an ss for the rhs. For operator expressions, we see the
7018 ss's for the operands. Any one of these will do. */
7020 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7021 if (rss->expr != expr1 && rss != loop->temp_ss)
7024 if (expr2 && rss == gfc_ss_terminator)
7027 gfc_start_block (&fblock);
7029 /* Since the lhs is allocatable, this must be a descriptor type.
7030 Get the data and array size. */
7031 desc = lss->data.info.descriptor;
7032 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7033 array1 = gfc_conv_descriptor_data_get (desc);
7035 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7036 deallocated if expr is an array of different shape or any of the
7037 corresponding length type parameter values of variable and expr
7038 differ." This assures F95 compatibility. */
7039 jump_label1 = gfc_build_label_decl (NULL_TREE);
7040 jump_label2 = gfc_build_label_decl (NULL_TREE);
7042 /* Allocate if data is NULL. */
7043 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7044 array1, build_int_cst (TREE_TYPE (array1), 0));
7045 tmp = build3_v (COND_EXPR, cond,
7046 build1_v (GOTO_EXPR, jump_label1),
7047 build_empty_stmt (input_location));
7048 gfc_add_expr_to_block (&fblock, tmp);
7050 /* Get arrayspec if expr is a full array. */
7051 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7052 && expr2->value.function.isym
7053 && expr2->value.function.isym->conversion)
7055 /* For conversion functions, take the arg. */
7056 gfc_expr *arg = expr2->value.function.actual->expr;
7057 as = gfc_get_full_arrayspec_from_expr (arg);
7060 as = gfc_get_full_arrayspec_from_expr (expr2);
7064 /* If the lhs shape is not the same as the rhs jump to setting the
7065 bounds and doing the reallocation....... */
7066 for (n = 0; n < expr1->rank; n++)
7068 /* Check the shape. */
7069 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7070 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7071 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7072 gfc_array_index_type,
7073 loop->to[n], loop->from[n]);
7074 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7075 gfc_array_index_type,
7077 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7078 gfc_array_index_type,
7080 cond = fold_build2_loc (input_location, NE_EXPR,
7082 tmp, gfc_index_zero_node);
7083 tmp = build3_v (COND_EXPR, cond,
7084 build1_v (GOTO_EXPR, jump_label1),
7085 build_empty_stmt (input_location));
7086 gfc_add_expr_to_block (&fblock, tmp);
7089 /* ....else jump past the (re)alloc code. */
7090 tmp = build1_v (GOTO_EXPR, jump_label2);
7091 gfc_add_expr_to_block (&fblock, tmp);
7093 /* Add the label to start automatic (re)allocation. */
7094 tmp = build1_v (LABEL_EXPR, jump_label1);
7095 gfc_add_expr_to_block (&fblock, tmp);
7097 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7099 /* Get the rhs size. Fix both sizes. */
7101 desc2 = rss->data.info.descriptor;
7104 size2 = gfc_index_one_node;
7105 for (n = 0; n < expr2->rank; n++)
7107 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7108 gfc_array_index_type,
7109 loop->to[n], loop->from[n]);
7110 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7111 gfc_array_index_type,
7112 tmp, gfc_index_one_node);
7113 size2 = fold_build2_loc (input_location, MULT_EXPR,
7114 gfc_array_index_type,
7118 size1 = gfc_evaluate_now (size1, &fblock);
7119 size2 = gfc_evaluate_now (size2, &fblock);
7121 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7123 neq_size = gfc_evaluate_now (cond, &fblock);
7126 /* Now modify the lhs descriptor and the associated scalarizer
7127 variables. F2003 7.4.1.3: "If variable is or becomes an
7128 unallocated allocatable variable, then it is allocated with each
7129 deferred type parameter equal to the corresponding type parameters
7130 of expr , with the shape of expr , and with each lower bound equal
7131 to the corresponding element of LBOUND(expr)."
7132 Reuse size1 to keep a dimension-by-dimension track of the
7133 stride of the new array. */
7134 size1 = gfc_index_one_node;
7135 offset = gfc_index_zero_node;
7137 for (n = 0; n < expr2->rank; n++)
7139 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7140 gfc_array_index_type,
7141 loop->to[n], loop->from[n]);
7142 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7143 gfc_array_index_type,
7144 tmp, gfc_index_one_node);
7146 lbound = gfc_index_one_node;
7151 lbd = get_std_lbound (expr2, desc2, n,
7152 as->type == AS_ASSUMED_SIZE);
7153 ubound = fold_build2_loc (input_location,
7155 gfc_array_index_type,
7157 ubound = fold_build2_loc (input_location,
7159 gfc_array_index_type,
7164 gfc_conv_descriptor_lbound_set (&fblock, desc,
7167 gfc_conv_descriptor_ubound_set (&fblock, desc,
7170 gfc_conv_descriptor_stride_set (&fblock, desc,
7173 lbound = gfc_conv_descriptor_lbound_get (desc,
7175 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7176 gfc_array_index_type,
7178 offset = fold_build2_loc (input_location, MINUS_EXPR,
7179 gfc_array_index_type,
7181 size1 = fold_build2_loc (input_location, MULT_EXPR,
7182 gfc_array_index_type,
7186 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7187 the array offset is saved and the info.offset is used for a
7188 running offset. Use the saved_offset instead. */
7189 tmp = gfc_conv_descriptor_offset (desc);
7190 gfc_add_modify (&fblock, tmp, offset);
7191 if (lss->data.info.saved_offset
7192 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7193 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7195 /* Now set the deltas for the lhs. */
7196 for (n = 0; n < expr1->rank; n++)
7198 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7199 dim = lss->data.info.dim[n];
7200 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7201 gfc_array_index_type, tmp,
7203 if (lss->data.info.delta[dim]
7204 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7205 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7208 /* Get the new lhs size in bytes. */
7209 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7211 tmp = expr2->ts.u.cl->backend_decl;
7212 gcc_assert (expr1->ts.u.cl->backend_decl);
7213 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7214 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7216 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7218 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7219 tmp = fold_build2_loc (input_location, MULT_EXPR,
7220 gfc_array_index_type, tmp,
7221 expr1->ts.u.cl->backend_decl);
7224 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7225 tmp = fold_convert (gfc_array_index_type, tmp);
7226 size2 = fold_build2_loc (input_location, MULT_EXPR,
7227 gfc_array_index_type,
7229 size2 = fold_convert (size_type_node, size2);
7230 size2 = gfc_evaluate_now (size2, &fblock);
7232 /* Realloc expression. Note that the scalarizer uses desc.data
7233 in the array reference - (*desc.data)[<element>]. */
7234 gfc_init_block (&realloc_block);
7235 tmp = build_call_expr_loc (input_location,
7236 built_in_decls[BUILT_IN_REALLOC], 2,
7237 fold_convert (pvoid_type_node, array1),
7239 gfc_conv_descriptor_data_set (&realloc_block,
7241 realloc_expr = gfc_finish_block (&realloc_block);
7243 /* Only reallocate if sizes are different. */
7244 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7245 build_empty_stmt (input_location));
7249 /* Malloc expression. */
7250 gfc_init_block (&alloc_block);
7251 tmp = build_call_expr_loc (input_location,
7252 built_in_decls[BUILT_IN_MALLOC], 1,
7254 gfc_conv_descriptor_data_set (&alloc_block,
7256 tmp = gfc_conv_descriptor_dtype (desc);
7257 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7258 alloc_expr = gfc_finish_block (&alloc_block);
7260 /* Malloc if not allocated; realloc otherwise. */
7261 tmp = build_int_cst (TREE_TYPE (array1), 0);
7262 cond = fold_build2_loc (input_location, EQ_EXPR,
7265 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7266 gfc_add_expr_to_block (&fblock, tmp);
7268 /* Make sure that the scalarizer data pointer is updated. */
7269 if (lss->data.info.data
7270 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7272 tmp = gfc_conv_descriptor_data_get (desc);
7273 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7276 /* Add the exit label. */
7277 tmp = build1_v (LABEL_EXPR, jump_label2);
7278 gfc_add_expr_to_block (&fblock, tmp);
7280 return gfc_finish_block (&fblock);
7284 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7285 Do likewise, recursively if necessary, with the allocatable components of
7289 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7295 stmtblock_t cleanup;
7298 bool sym_has_alloc_comp;
7300 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7301 || sym->ts.type == BT_CLASS)
7302 && sym->ts.u.derived->attr.alloc_comp;
7304 /* Make sure the frontend gets these right. */
7305 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7306 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7307 "allocatable attribute or derived type without allocatable "
7310 gfc_save_backend_locus (&loc);
7311 gfc_set_backend_locus (&sym->declared_at);
7312 gfc_init_block (&init);
7314 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7315 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7317 if (sym->ts.type == BT_CHARACTER
7318 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7320 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7321 gfc_trans_vla_type_sizes (sym, &init);
7324 /* Dummy, use associated and result variables don't need anything special. */
7325 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7327 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7328 gfc_restore_backend_locus (&loc);
7332 descriptor = sym->backend_decl;
7334 /* Although static, derived types with default initializers and
7335 allocatable components must not be nulled wholesale; instead they
7336 are treated component by component. */
7337 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7339 /* SAVEd variables are not freed on exit. */
7340 gfc_trans_static_array_pointer (sym);
7342 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7343 gfc_restore_backend_locus (&loc);
7347 /* Get the descriptor type. */
7348 type = TREE_TYPE (sym->backend_decl);
7350 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7353 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7355 if (sym->value == NULL
7356 || !gfc_has_default_initializer (sym->ts.u.derived))
7358 rank = sym->as ? sym->as->rank : 0;
7359 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7361 gfc_add_expr_to_block (&init, tmp);
7364 gfc_init_default_dt (sym, &init, false);
7367 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7369 /* If the backend_decl is not a descriptor, we must have a pointer
7371 descriptor = build_fold_indirect_ref_loc (input_location,
7373 type = TREE_TYPE (descriptor);
7376 /* NULLIFY the data pointer. */
7377 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7378 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7380 gfc_restore_backend_locus (&loc);
7381 gfc_init_block (&cleanup);
7383 /* Allocatable arrays need to be freed when they go out of scope.
7384 The allocatable components of pointers must not be touched. */
7385 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7386 && !sym->attr.pointer && !sym->attr.save)
7389 rank = sym->as ? sym->as->rank : 0;
7390 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7391 gfc_add_expr_to_block (&cleanup, tmp);
7394 if (sym->attr.allocatable && sym->attr.dimension
7395 && !sym->attr.save && !sym->attr.result)
7397 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7398 gfc_add_expr_to_block (&cleanup, tmp);
7401 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7402 gfc_finish_block (&cleanup));
7405 /************ Expression Walking Functions ******************/
7407 /* Walk a variable reference.
7409 Possible extension - multiple component subscripts.
7410 x(:,:) = foo%a(:)%b(:)
7412 forall (i=..., j=...)
7413 x(i,j) = foo%a(j)%b(i)
7415 This adds a fair amount of complexity because you need to deal with more
7416 than one ref. Maybe handle in a similar manner to vector subscripts.
7417 Maybe not worth the effort. */
7421 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7428 for (ref = expr->ref; ref; ref = ref->next)
7429 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7432 for (; ref; ref = ref->next)
7434 if (ref->type == REF_SUBSTRING)
7436 newss = gfc_get_ss ();
7437 newss->type = GFC_SS_SCALAR;
7438 newss->expr = ref->u.ss.start;
7442 newss = gfc_get_ss ();
7443 newss->type = GFC_SS_SCALAR;
7444 newss->expr = ref->u.ss.end;
7449 /* We're only interested in array sections from now on. */
7450 if (ref->type != REF_ARRAY)
7455 if (ar->as->rank == 0 && ref->next != NULL)
7457 /* Scalar coarray. */
7464 for (n = 0; n < ar->dimen + ar->codimen; n++)
7466 newss = gfc_get_ss ();
7467 newss->type = GFC_SS_SCALAR;
7468 newss->expr = ar->start[n];
7475 newss = gfc_get_ss ();
7476 newss->type = GFC_SS_SECTION;
7479 newss->data.info.dimen = ar->as->rank;
7480 newss->data.info.codimen = 0;
7481 newss->data.info.ref = ref;
7483 /* Make sure array is the same as array(:,:), this way
7484 we don't need to special case all the time. */
7485 ar->dimen = ar->as->rank;
7487 for (n = 0; n < ar->dimen; n++)
7489 newss->data.info.dim[n] = n;
7490 ar->dimen_type[n] = DIMEN_RANGE;
7492 gcc_assert (ar->start[n] == NULL);
7493 gcc_assert (ar->end[n] == NULL);
7494 gcc_assert (ar->stride[n] == NULL);
7496 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7498 newss->data.info.dim[n] = n;
7499 ar->dimen_type[n] = DIMEN_RANGE;
7501 gcc_assert (ar->start[n] == NULL);
7502 gcc_assert (ar->end[n] == NULL);
7508 newss = gfc_get_ss ();
7509 newss->type = GFC_SS_SECTION;
7512 newss->data.info.dimen = 0;
7513 newss->data.info.codimen = 0;
7514 newss->data.info.ref = ref;
7516 /* We add SS chains for all the subscripts in the section. */
7517 for (n = 0; n < ar->dimen + ar->codimen; n++)
7521 switch (ar->dimen_type[n])
7523 case DIMEN_THIS_IMAGE:
7526 /* Add SS for elemental (scalar) subscripts. */
7527 gcc_assert (ar->start[n]);
7528 indexss = gfc_get_ss ();
7529 indexss->type = GFC_SS_SCALAR;
7530 indexss->expr = ar->start[n];
7531 indexss->next = gfc_ss_terminator;
7532 indexss->loop_chain = gfc_ss_terminator;
7533 newss->data.info.subscript[n] = indexss;
7537 /* We don't add anything for sections, just remember this
7538 dimension for later. */
7539 newss->data.info.dim[newss->data.info.dimen
7540 + newss->data.info.codimen] = n;
7542 newss->data.info.dimen++;
7546 /* Create a GFC_SS_VECTOR index in which we can store
7547 the vector's descriptor. */
7548 indexss = gfc_get_ss ();
7549 indexss->type = GFC_SS_VECTOR;
7550 indexss->expr = ar->start[n];
7551 indexss->next = gfc_ss_terminator;
7552 indexss->loop_chain = gfc_ss_terminator;
7553 newss->data.info.subscript[n] = indexss;
7554 newss->data.info.dim[newss->data.info.dimen
7555 + newss->data.info.codimen] = n;
7557 newss->data.info.dimen++;
7561 /* We should know what sort of section it is by now. */
7565 /* We should have at least one non-elemental dimension. */
7566 gcc_assert (newss->data.info.dimen > 0);
7571 /* We should know what sort of section it is by now. */
7580 /* Walk an expression operator. If only one operand of a binary expression is
7581 scalar, we must also add the scalar term to the SS chain. */
7584 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7590 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7591 if (expr->value.op.op2 == NULL)
7594 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7596 /* All operands are scalar. Pass back and let the caller deal with it. */
7600 /* All operands require scalarization. */
7601 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7604 /* One of the operands needs scalarization, the other is scalar.
7605 Create a gfc_ss for the scalar expression. */
7606 newss = gfc_get_ss ();
7607 newss->type = GFC_SS_SCALAR;
7610 /* First operand is scalar. We build the chain in reverse order, so
7611 add the scalar SS after the second operand. */
7613 while (head && head->next != ss)
7615 /* Check we haven't somehow broken the chain. */
7619 newss->expr = expr->value.op.op1;
7621 else /* head2 == head */
7623 gcc_assert (head2 == head);
7624 /* Second operand is scalar. */
7625 newss->next = head2;
7627 newss->expr = expr->value.op.op2;
7634 /* Reverse a SS chain. */
7637 gfc_reverse_ss (gfc_ss * ss)
7642 gcc_assert (ss != NULL);
7644 head = gfc_ss_terminator;
7645 while (ss != gfc_ss_terminator)
7648 /* Check we didn't somehow break the chain. */
7649 gcc_assert (next != NULL);
7659 /* Walk the arguments of an elemental function. */
7662 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7670 head = gfc_ss_terminator;
7673 for (; arg; arg = arg->next)
7678 newss = gfc_walk_subexpr (head, arg->expr);
7681 /* Scalar argument. */
7682 newss = gfc_get_ss ();
7684 newss->expr = arg->expr;
7694 while (tail->next != gfc_ss_terminator)
7701 /* If all the arguments are scalar we don't need the argument SS. */
7702 gfc_free_ss_chain (head);
7707 /* Add it onto the existing chain. */
7713 /* Walk a function call. Scalar functions are passed back, and taken out of
7714 scalarization loops. For elemental functions we walk their arguments.
7715 The result of functions returning arrays is stored in a temporary outside
7716 the loop, so that the function is only called once. Hence we do not need
7717 to walk their arguments. */
7720 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7723 gfc_intrinsic_sym *isym;
7725 gfc_component *comp = NULL;
7728 isym = expr->value.function.isym;
7730 /* Handle intrinsic functions separately. */
7732 return gfc_walk_intrinsic_function (ss, expr, isym);
7734 sym = expr->value.function.esym;
7736 sym = expr->symtree->n.sym;
7738 /* A function that returns arrays. */
7739 gfc_is_proc_ptr_comp (expr, &comp);
7740 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7741 || (comp && comp->attr.dimension))
7743 newss = gfc_get_ss ();
7744 newss->type = GFC_SS_FUNCTION;
7747 newss->data.info.dimen = expr->rank;
7748 for (n = 0; n < newss->data.info.dimen; n++)
7749 newss->data.info.dim[n] = n;
7753 /* Walk the parameters of an elemental function. For now we always pass
7755 if (sym->attr.elemental)
7756 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7759 /* Scalar functions are OK as these are evaluated outside the scalarization
7760 loop. Pass back and let the caller deal with it. */
7765 /* An array temporary is constructed for array constructors. */
7768 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7773 newss = gfc_get_ss ();
7774 newss->type = GFC_SS_CONSTRUCTOR;
7777 newss->data.info.dimen = expr->rank;
7778 for (n = 0; n < expr->rank; n++)
7779 newss->data.info.dim[n] = n;
7785 /* Walk an expression. Add walked expressions to the head of the SS chain.
7786 A wholly scalar expression will not be added. */
7789 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7793 switch (expr->expr_type)
7796 head = gfc_walk_variable_expr (ss, expr);
7800 head = gfc_walk_op_expr (ss, expr);
7804 head = gfc_walk_function_expr (ss, expr);
7809 case EXPR_STRUCTURE:
7810 /* Pass back and let the caller deal with it. */
7814 head = gfc_walk_array_constructor (ss, expr);
7817 case EXPR_SUBSTRING:
7818 /* Pass back and let the caller deal with it. */
7822 internal_error ("bad expression type during walk (%d)",
7829 /* Entry point for expression walking.
7830 A return value equal to the passed chain means this is
7831 a scalar expression. It is up to the caller to take whatever action is
7832 necessary to translate these. */
7835 gfc_walk_expr (gfc_expr * expr)
7839 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7840 return gfc_reverse_ss (res);