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);
2627 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2628 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2631 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2632 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2633 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2635 /* Use the actual tree type and not the wrapped coarray. */
2636 if (!se->want_pointer)
2637 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2644 /* Handle scalarized references separately. */
2645 if (ar->type != AR_ELEMENT)
2647 gfc_conv_scalarized_array_ref (se, ar);
2648 gfc_advance_se_ss_chain (se);
2652 index = gfc_index_zero_node;
2654 /* Calculate the offsets from all the dimensions. */
2655 for (n = 0; n < ar->dimen; n++)
2657 /* Calculate the index for this dimension. */
2658 gfc_init_se (&indexse, se);
2659 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2660 gfc_add_block_to_block (&se->pre, &indexse.pre);
2662 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2664 /* Check array bounds. */
2668 /* Evaluate the indexse.expr only once. */
2669 indexse.expr = save_expr (indexse.expr);
2672 tmp = gfc_conv_array_lbound (se->expr, n);
2673 if (sym->attr.temporary)
2675 gfc_init_se (&tmpse, se);
2676 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2677 gfc_array_index_type);
2678 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2682 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2684 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2685 "below lower bound of %%ld", n+1, sym->name);
2686 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2687 fold_convert (long_integer_type_node,
2689 fold_convert (long_integer_type_node, tmp));
2692 /* Upper bound, but not for the last dimension of assumed-size
2694 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2696 tmp = gfc_conv_array_ubound (se->expr, n);
2697 if (sym->attr.temporary)
2699 gfc_init_se (&tmpse, se);
2700 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2701 gfc_array_index_type);
2702 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2706 cond = fold_build2_loc (input_location, GT_EXPR,
2707 boolean_type_node, indexse.expr, tmp);
2708 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2709 "above upper bound of %%ld", n+1, sym->name);
2710 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2711 fold_convert (long_integer_type_node,
2713 fold_convert (long_integer_type_node, tmp));
2718 /* Multiply the index by the stride. */
2719 stride = gfc_conv_array_stride (se->expr, n);
2720 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2721 indexse.expr, stride);
2723 /* And add it to the total. */
2724 index = fold_build2_loc (input_location, PLUS_EXPR,
2725 gfc_array_index_type, index, tmp);
2728 tmp = gfc_conv_array_offset (se->expr);
2729 if (!integer_zerop (tmp))
2730 index = fold_build2_loc (input_location, PLUS_EXPR,
2731 gfc_array_index_type, index, tmp);
2733 /* Access the calculated element. */
2734 tmp = gfc_conv_array_data (se->expr);
2735 tmp = build_fold_indirect_ref (tmp);
2736 se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2740 /* Generate the code to be executed immediately before entering a
2741 scalarization loop. */
2744 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2745 stmtblock_t * pblock)
2754 /* This code will be executed before entering the scalarization loop
2755 for this dimension. */
2756 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2758 if ((ss->useflags & flag) == 0)
2761 if (ss->type != GFC_SS_SECTION
2762 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2763 && ss->type != GFC_SS_COMPONENT)
2766 info = &ss->data.info;
2768 if (dim >= info->dimen)
2771 if (dim == info->dimen - 1)
2773 /* For the outermost loop calculate the offset due to any
2774 elemental dimensions. It will have been initialized with the
2775 base offset of the array. */
2778 for (i = 0; i < info->ref->u.ar.dimen; i++)
2780 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2783 gfc_init_se (&se, NULL);
2785 se.expr = info->descriptor;
2786 stride = gfc_conv_array_stride (info->descriptor, i);
2787 index = gfc_conv_array_index_offset (&se, info, i, -1,
2790 gfc_add_block_to_block (pblock, &se.pre);
2792 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2793 gfc_array_index_type,
2794 info->offset, index);
2795 info->offset = gfc_evaluate_now (info->offset, pblock);
2800 /* For the time being, the innermost loop is unconditionally on
2801 the first dimension of the scalarization loop. */
2802 gcc_assert (i == 0);
2803 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2805 /* Calculate the stride of the innermost loop. Hopefully this will
2806 allow the backend optimizers to do their stuff more effectively.
2808 info->stride0 = gfc_evaluate_now (stride, pblock);
2812 /* Add the offset for the previous loop dimension. */
2817 ar = &info->ref->u.ar;
2818 i = loop->order[dim + 1];
2826 gfc_init_se (&se, NULL);
2828 se.expr = info->descriptor;
2829 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2830 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2832 gfc_add_block_to_block (pblock, &se.pre);
2833 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2834 gfc_array_index_type, info->offset,
2836 info->offset = gfc_evaluate_now (info->offset, pblock);
2839 /* Remember this offset for the second loop. */
2840 if (dim == loop->temp_dim - 1)
2841 info->saved_offset = info->offset;
2846 /* Start a scalarized expression. Creates a scope and declares loop
2850 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2856 gcc_assert (!loop->array_parameter);
2858 for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
2860 n = loop->order[dim];
2862 gfc_start_block (&loop->code[n]);
2864 /* Create the loop variable. */
2865 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2867 if (dim < loop->temp_dim)
2871 /* Calculate values that will be constant within this loop. */
2872 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2874 gfc_start_block (pbody);
2878 /* Generates the actual loop code for a scalarization loop. */
2881 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2882 stmtblock_t * pbody)
2893 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2894 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2895 && n == loop->dimen - 1)
2897 /* We create an OMP_FOR construct for the outermost scalarized loop. */
2898 init = make_tree_vec (1);
2899 cond = make_tree_vec (1);
2900 incr = make_tree_vec (1);
2902 /* Cycle statement is implemented with a goto. Exit statement must not
2903 be present for this loop. */
2904 exit_label = gfc_build_label_decl (NULL_TREE);
2905 TREE_USED (exit_label) = 1;
2907 /* Label for cycle statements (if needed). */
2908 tmp = build1_v (LABEL_EXPR, exit_label);
2909 gfc_add_expr_to_block (pbody, tmp);
2911 stmt = make_node (OMP_FOR);
2913 TREE_TYPE (stmt) = void_type_node;
2914 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2916 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2917 OMP_CLAUSE_SCHEDULE);
2918 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2919 = OMP_CLAUSE_SCHEDULE_STATIC;
2920 if (ompws_flags & OMPWS_NOWAIT)
2921 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2922 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2924 /* Initialize the loopvar. */
2925 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2927 OMP_FOR_INIT (stmt) = init;
2928 /* The exit condition. */
2929 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
2931 loop->loopvar[n], loop->to[n]);
2932 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
2933 OMP_FOR_COND (stmt) = cond;
2934 /* Increment the loopvar. */
2935 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2936 loop->loopvar[n], gfc_index_one_node);
2937 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
2938 void_type_node, loop->loopvar[n], tmp);
2939 OMP_FOR_INCR (stmt) = incr;
2941 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2942 gfc_add_expr_to_block (&loop->code[n], stmt);
2946 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
2947 && (loop->temp_ss == NULL);
2949 loopbody = gfc_finish_block (pbody);
2953 tmp = loop->from[n];
2954 loop->from[n] = loop->to[n];
2958 /* Initialize the loopvar. */
2959 if (loop->loopvar[n] != loop->from[n])
2960 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2962 exit_label = gfc_build_label_decl (NULL_TREE);
2964 /* Generate the loop body. */
2965 gfc_init_block (&block);
2967 /* The exit condition. */
2968 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
2969 boolean_type_node, loop->loopvar[n], loop->to[n]);
2970 tmp = build1_v (GOTO_EXPR, exit_label);
2971 TREE_USED (exit_label) = 1;
2972 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2973 gfc_add_expr_to_block (&block, tmp);
2975 /* The main body. */
2976 gfc_add_expr_to_block (&block, loopbody);
2978 /* Increment the loopvar. */
2979 tmp = fold_build2_loc (input_location,
2980 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
2981 gfc_array_index_type, loop->loopvar[n],
2982 gfc_index_one_node);
2984 gfc_add_modify (&block, loop->loopvar[n], tmp);
2986 /* Build the loop. */
2987 tmp = gfc_finish_block (&block);
2988 tmp = build1_v (LOOP_EXPR, tmp);
2989 gfc_add_expr_to_block (&loop->code[n], tmp);
2991 /* Add the exit label. */
2992 tmp = build1_v (LABEL_EXPR, exit_label);
2993 gfc_add_expr_to_block (&loop->code[n], tmp);
2999 /* Finishes and generates the loops for a scalarized expression. */
3002 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3007 stmtblock_t *pblock;
3011 /* Generate the loops. */
3012 for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
3014 n = loop->order[dim];
3015 gfc_trans_scalarized_loop_end (loop, n, pblock);
3016 loop->loopvar[n] = NULL_TREE;
3017 pblock = &loop->code[n];
3020 tmp = gfc_finish_block (pblock);
3021 gfc_add_expr_to_block (&loop->pre, tmp);
3023 /* Clear all the used flags. */
3024 for (ss = loop->ss; ss; ss = ss->loop_chain)
3029 /* Finish the main body of a scalarized expression, and start the secondary
3033 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3037 stmtblock_t *pblock;
3041 /* We finish as many loops as are used by the temporary. */
3042 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3044 n = loop->order[dim];
3045 gfc_trans_scalarized_loop_end (loop, n, pblock);
3046 loop->loopvar[n] = NULL_TREE;
3047 pblock = &loop->code[n];
3050 /* We don't want to finish the outermost loop entirely. */
3051 n = loop->order[loop->temp_dim - 1];
3052 gfc_trans_scalarized_loop_end (loop, n, pblock);
3054 /* Restore the initial offsets. */
3055 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3057 if ((ss->useflags & 2) == 0)
3060 if (ss->type != GFC_SS_SECTION
3061 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
3062 && ss->type != GFC_SS_COMPONENT)
3065 ss->data.info.offset = ss->data.info.saved_offset;
3068 /* Restart all the inner loops we just finished. */
3069 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3071 n = loop->order[dim];
3073 gfc_start_block (&loop->code[n]);
3075 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3077 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3080 /* Start a block for the secondary copying code. */
3081 gfc_start_block (body);
3085 /* Calculate the lower bound of an array section. */
3088 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
3089 bool coarray, bool coarray_last)
3093 gfc_expr *stride = NULL;
3098 gcc_assert (ss->type == GFC_SS_SECTION);
3100 info = &ss->data.info;
3102 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3104 /* We use a zero-based index to access the vector. */
3105 info->start[dim] = gfc_index_zero_node;
3106 info->end[dim] = NULL;
3108 info->stride[dim] = gfc_index_one_node;
3112 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3113 desc = info->descriptor;
3114 start = info->ref->u.ar.start[dim];
3115 end = info->ref->u.ar.end[dim];
3117 stride = info->ref->u.ar.stride[dim];
3119 /* Calculate the start of the range. For vector subscripts this will
3120 be the range of the vector. */
3123 /* Specified section start. */
3124 gfc_init_se (&se, NULL);
3125 gfc_conv_expr_type (&se, start, gfc_array_index_type);
3126 gfc_add_block_to_block (&loop->pre, &se.pre);
3127 info->start[dim] = se.expr;
3131 /* No lower bound specified so use the bound of the array. */
3132 info->start[dim] = gfc_conv_array_lbound (desc, dim);
3134 info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
3136 /* Similarly calculate the end. Although this is not used in the
3137 scalarizer, it is needed when checking bounds and where the end
3138 is an expression with side-effects. */
3143 /* Specified section start. */
3144 gfc_init_se (&se, NULL);
3145 gfc_conv_expr_type (&se, end, gfc_array_index_type);
3146 gfc_add_block_to_block (&loop->pre, &se.pre);
3147 info->end[dim] = se.expr;
3151 /* No upper bound specified so use the bound of the array. */
3152 info->end[dim] = gfc_conv_array_ubound (desc, dim);
3154 info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
3157 /* Calculate the stride. */
3158 if (!coarray && stride == NULL)
3159 info->stride[dim] = gfc_index_one_node;
3162 gfc_init_se (&se, NULL);
3163 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3164 gfc_add_block_to_block (&loop->pre, &se.pre);
3165 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3170 /* Calculates the range start and stride for a SS chain. Also gets the
3171 descriptor and data pointer. The range of vector subscripts is the size
3172 of the vector. Array bounds are also checked. */
3175 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3183 /* Determine the rank of the loop. */
3185 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3189 case GFC_SS_SECTION:
3190 case GFC_SS_CONSTRUCTOR:
3191 case GFC_SS_FUNCTION:
3192 case GFC_SS_COMPONENT:
3193 loop->dimen = ss->data.info.dimen;
3194 loop->codimen = ss->data.info.codimen;
3197 /* As usual, lbound and ubound are exceptions!. */
3198 case GFC_SS_INTRINSIC:
3199 switch (ss->expr->value.function.isym->id)
3201 case GFC_ISYM_LBOUND:
3202 case GFC_ISYM_UBOUND:
3203 loop->dimen = ss->data.info.dimen;
3207 case GFC_ISYM_LCOBOUND:
3208 case GFC_ISYM_UCOBOUND:
3209 case GFC_ISYM_THIS_IMAGE:
3210 loop->dimen = ss->data.info.dimen;
3211 loop->codimen = ss->data.info.codimen;
3223 /* We should have determined the rank of the expression by now. If
3224 not, that's bad news. */
3225 gcc_assert (loop->dimen + loop->codimen != 0);
3227 /* Loop over all the SS in the chain. */
3228 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3230 if (ss->expr && ss->expr->shape && !ss->shape)
3231 ss->shape = ss->expr->shape;
3235 case GFC_SS_SECTION:
3236 /* Get the descriptor for the array. */
3237 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3239 for (n = 0; n < ss->data.info.dimen; n++)
3240 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
3242 for (n = ss->data.info.dimen;
3243 n < ss->data.info.dimen + ss->data.info.codimen; n++)
3244 gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
3245 n == ss->data.info.dimen
3246 + ss->data.info.codimen -1);
3250 case GFC_SS_INTRINSIC:
3251 switch (ss->expr->value.function.isym->id)
3253 /* Fall through to supply start and stride. */
3254 case GFC_ISYM_LBOUND:
3255 case GFC_ISYM_UBOUND:
3256 case GFC_ISYM_LCOBOUND:
3257 case GFC_ISYM_UCOBOUND:
3258 case GFC_ISYM_THIS_IMAGE:
3265 case GFC_SS_CONSTRUCTOR:
3266 case GFC_SS_FUNCTION:
3267 for (n = 0; n < ss->data.info.dimen; n++)
3269 ss->data.info.start[n] = gfc_index_zero_node;
3270 ss->data.info.end[n] = gfc_index_zero_node;
3271 ss->data.info.stride[n] = gfc_index_one_node;
3280 /* The rest is just runtime bound checking. */
3281 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3284 tree lbound, ubound;
3286 tree size[GFC_MAX_DIMENSIONS];
3287 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3292 gfc_start_block (&block);
3294 for (n = 0; n < loop->dimen; n++)
3295 size[n] = NULL_TREE;
3297 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3301 if (ss->type != GFC_SS_SECTION)
3304 /* Catch allocatable lhs in f2003. */
3305 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3308 gfc_start_block (&inner);
3310 /* TODO: range checking for mapped dimensions. */
3311 info = &ss->data.info;
3313 /* This code only checks ranges. Elemental and vector
3314 dimensions are checked later. */
3315 for (n = 0; n < loop->dimen; n++)
3320 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3323 if (dim == info->ref->u.ar.dimen - 1
3324 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3325 check_upper = false;
3329 /* Zero stride is not allowed. */
3330 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3331 info->stride[dim], gfc_index_zero_node);
3332 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3333 "of array '%s'", dim + 1, ss->expr->symtree->name);
3334 gfc_trans_runtime_check (true, false, tmp, &inner,
3335 &ss->expr->where, msg);
3338 desc = ss->data.info.descriptor;
3340 /* This is the run-time equivalent of resolve.c's
3341 check_dimension(). The logical is more readable there
3342 than it is here, with all the trees. */
3343 lbound = gfc_conv_array_lbound (desc, dim);
3344 end = info->end[dim];
3346 ubound = gfc_conv_array_ubound (desc, dim);
3350 /* non_zerosized is true when the selected range is not
3352 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3353 boolean_type_node, info->stride[dim],
3354 gfc_index_zero_node);
3355 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3356 info->start[dim], end);
3357 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3358 boolean_type_node, stride_pos, tmp);
3360 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3362 info->stride[dim], gfc_index_zero_node);
3363 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3364 info->start[dim], end);
3365 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3368 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3370 stride_pos, stride_neg);
3372 /* Check the start of the range against the lower and upper
3373 bounds of the array, if the range is not empty.
3374 If upper bound is present, include both bounds in the
3378 tmp = fold_build2_loc (input_location, LT_EXPR,
3380 info->start[dim], lbound);
3381 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3383 non_zerosized, tmp);
3384 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3386 info->start[dim], ubound);
3387 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3389 non_zerosized, tmp2);
3390 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3391 "outside of expected range (%%ld:%%ld)",
3392 dim + 1, ss->expr->symtree->name);
3393 gfc_trans_runtime_check (true, false, tmp, &inner,
3394 &ss->expr->where, msg,
3395 fold_convert (long_integer_type_node, info->start[dim]),
3396 fold_convert (long_integer_type_node, lbound),
3397 fold_convert (long_integer_type_node, ubound));
3398 gfc_trans_runtime_check (true, false, tmp2, &inner,
3399 &ss->expr->where, msg,
3400 fold_convert (long_integer_type_node, info->start[dim]),
3401 fold_convert (long_integer_type_node, lbound),
3402 fold_convert (long_integer_type_node, ubound));
3407 tmp = fold_build2_loc (input_location, LT_EXPR,
3409 info->start[dim], lbound);
3410 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3411 boolean_type_node, non_zerosized, tmp);
3412 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3413 "below lower bound of %%ld",
3414 dim + 1, ss->expr->symtree->name);
3415 gfc_trans_runtime_check (true, false, tmp, &inner,
3416 &ss->expr->where, msg,
3417 fold_convert (long_integer_type_node, info->start[dim]),
3418 fold_convert (long_integer_type_node, lbound));
3422 /* Compute the last element of the range, which is not
3423 necessarily "end" (think 0:5:3, which doesn't contain 5)
3424 and check it against both lower and upper bounds. */
3426 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3427 gfc_array_index_type, end,
3429 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3430 gfc_array_index_type, tmp,
3432 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3433 gfc_array_index_type, end, tmp);
3434 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3435 boolean_type_node, tmp, lbound);
3436 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3437 boolean_type_node, non_zerosized, tmp2);
3440 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3441 boolean_type_node, tmp, ubound);
3442 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3443 boolean_type_node, non_zerosized, tmp3);
3444 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3445 "outside of expected range (%%ld:%%ld)",
3446 dim + 1, ss->expr->symtree->name);
3447 gfc_trans_runtime_check (true, false, tmp2, &inner,
3448 &ss->expr->where, msg,
3449 fold_convert (long_integer_type_node, tmp),
3450 fold_convert (long_integer_type_node, ubound),
3451 fold_convert (long_integer_type_node, lbound));
3452 gfc_trans_runtime_check (true, false, tmp3, &inner,
3453 &ss->expr->where, msg,
3454 fold_convert (long_integer_type_node, tmp),
3455 fold_convert (long_integer_type_node, ubound),
3456 fold_convert (long_integer_type_node, lbound));
3461 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3462 "below lower bound of %%ld",
3463 dim + 1, ss->expr->symtree->name);
3464 gfc_trans_runtime_check (true, false, tmp2, &inner,
3465 &ss->expr->where, msg,
3466 fold_convert (long_integer_type_node, tmp),
3467 fold_convert (long_integer_type_node, lbound));
3471 /* Check the section sizes match. */
3472 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3473 gfc_array_index_type, end,
3475 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3476 gfc_array_index_type, tmp,
3478 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3479 gfc_array_index_type,
3480 gfc_index_one_node, tmp);
3481 tmp = fold_build2_loc (input_location, MAX_EXPR,
3482 gfc_array_index_type, tmp,
3483 build_int_cst (gfc_array_index_type, 0));
3484 /* We remember the size of the first section, and check all the
3485 others against this. */
3488 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3489 boolean_type_node, tmp, size[n]);
3490 asprintf (&msg, "Array bound mismatch for dimension %d "
3491 "of array '%s' (%%ld/%%ld)",
3492 dim + 1, ss->expr->symtree->name);
3494 gfc_trans_runtime_check (true, false, tmp3, &inner,
3495 &ss->expr->where, msg,
3496 fold_convert (long_integer_type_node, tmp),
3497 fold_convert (long_integer_type_node, size[n]));
3502 size[n] = gfc_evaluate_now (tmp, &inner);
3505 tmp = gfc_finish_block (&inner);
3507 /* For optional arguments, only check bounds if the argument is
3509 if (ss->expr->symtree->n.sym->attr.optional
3510 || ss->expr->symtree->n.sym->attr.not_always_present)
3511 tmp = build3_v (COND_EXPR,
3512 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3513 tmp, build_empty_stmt (input_location));
3515 gfc_add_expr_to_block (&block, tmp);
3519 tmp = gfc_finish_block (&block);
3520 gfc_add_expr_to_block (&loop->pre, tmp);
3524 /* Return true if both symbols could refer to the same data object. Does
3525 not take account of aliasing due to equivalence statements. */
3528 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3529 bool lsym_target, bool rsym_pointer, bool rsym_target)
3531 /* Aliasing isn't possible if the symbols have different base types. */
3532 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3535 /* Pointers can point to other pointers and target objects. */
3537 if ((lsym_pointer && (rsym_pointer || rsym_target))
3538 || (rsym_pointer && (lsym_pointer || lsym_target)))
3541 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3542 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3544 if (lsym_target && rsym_target
3545 && ((lsym->attr.dummy && !lsym->attr.contiguous
3546 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3547 || (rsym->attr.dummy && !rsym->attr.contiguous
3548 && (!rsym->attr.dimension
3549 || rsym->as->type == AS_ASSUMED_SHAPE))))
3556 /* Return true if the two SS could be aliased, i.e. both point to the same data
3558 /* TODO: resolve aliases based on frontend expressions. */
3561 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3567 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3569 lsym = lss->expr->symtree->n.sym;
3570 rsym = rss->expr->symtree->n.sym;
3572 lsym_pointer = lsym->attr.pointer;
3573 lsym_target = lsym->attr.target;
3574 rsym_pointer = rsym->attr.pointer;
3575 rsym_target = rsym->attr.target;
3577 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3578 rsym_pointer, rsym_target))
3581 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3582 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3585 /* For derived types we must check all the component types. We can ignore
3586 array references as these will have the same base type as the previous
3588 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3590 if (lref->type != REF_COMPONENT)
3593 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3594 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3596 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3597 rsym_pointer, rsym_target))
3600 if ((lsym_pointer && (rsym_pointer || rsym_target))
3601 || (rsym_pointer && (lsym_pointer || lsym_target)))
3603 if (gfc_compare_types (&lref->u.c.component->ts,
3608 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3611 if (rref->type != REF_COMPONENT)
3614 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3615 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3617 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3618 lsym_pointer, lsym_target,
3619 rsym_pointer, rsym_target))
3622 if ((lsym_pointer && (rsym_pointer || rsym_target))
3623 || (rsym_pointer && (lsym_pointer || lsym_target)))
3625 if (gfc_compare_types (&lref->u.c.component->ts,
3626 &rref->u.c.sym->ts))
3628 if (gfc_compare_types (&lref->u.c.sym->ts,
3629 &rref->u.c.component->ts))
3631 if (gfc_compare_types (&lref->u.c.component->ts,
3632 &rref->u.c.component->ts))
3638 lsym_pointer = lsym->attr.pointer;
3639 lsym_target = lsym->attr.target;
3640 lsym_pointer = lsym->attr.pointer;
3641 lsym_target = lsym->attr.target;
3643 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3645 if (rref->type != REF_COMPONENT)
3648 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3649 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3651 if (symbols_could_alias (rref->u.c.sym, lsym,
3652 lsym_pointer, lsym_target,
3653 rsym_pointer, rsym_target))
3656 if ((lsym_pointer && (rsym_pointer || rsym_target))
3657 || (rsym_pointer && (lsym_pointer || lsym_target)))
3659 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3668 /* Resolve array data dependencies. Creates a temporary if required. */
3669 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3673 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3682 loop->temp_ss = NULL;
3684 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3686 if (ss->type != GFC_SS_SECTION)
3689 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3691 if (gfc_could_be_alias (dest, ss)
3692 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3700 lref = dest->expr->ref;
3701 rref = ss->expr->ref;
3703 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3708 for (i = 0; i < dest->data.info.dimen; i++)
3709 for (j = 0; j < ss->data.info.dimen; j++)
3711 && dest->data.info.dim[i] == ss->data.info.dim[j])
3713 /* If we don't access array elements in the same order,
3714 there is a dependency. */
3719 /* TODO : loop shifting. */
3722 /* Mark the dimensions for LOOP SHIFTING */
3723 for (n = 0; n < loop->dimen; n++)
3725 int dim = dest->data.info.dim[n];
3727 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3729 else if (! gfc_is_same_range (&lref->u.ar,
3730 &rref->u.ar, dim, 0))
3734 /* Put all the dimensions with dependencies in the
3737 for (n = 0; n < loop->dimen; n++)
3739 gcc_assert (loop->order[n] == n);
3741 loop->order[dim++] = n;
3743 for (n = 0; n < loop->dimen; n++)
3746 loop->order[dim++] = n;
3749 gcc_assert (dim == loop->dimen);
3760 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3761 if (GFC_ARRAY_TYPE_P (base_type)
3762 || GFC_DESCRIPTOR_TYPE_P (base_type))
3763 base_type = gfc_get_element_type (base_type);
3764 loop->temp_ss = gfc_get_ss ();
3765 loop->temp_ss->type = GFC_SS_TEMP;
3766 loop->temp_ss->data.temp.type = base_type;
3767 loop->temp_ss->string_length = dest->string_length;
3768 loop->temp_ss->data.temp.dimen = loop->dimen;
3769 loop->temp_ss->data.temp.codimen = loop->codimen;
3770 loop->temp_ss->next = gfc_ss_terminator;
3771 gfc_add_ss_to_loop (loop, loop->temp_ss);
3774 loop->temp_ss = NULL;
3778 /* Initialize the scalarization loop. Creates the loop variables. Determines
3779 the range of the loop variables. Creates a temporary if required.
3780 Calculates how to transform from loop variables to array indices for each
3781 expression. Also generates code for scalar expressions which have been
3782 moved outside the loop. */
3785 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3787 int n, dim, spec_dim;
3789 gfc_ss_info *specinfo;
3792 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3793 bool dynamic[GFC_MAX_DIMENSIONS];
3798 for (n = 0; n < loop->dimen + loop->codimen; n++)
3802 /* We use one SS term, and use that to determine the bounds of the
3803 loop for this dimension. We try to pick the simplest term. */
3804 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3806 if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE)
3809 info = &ss->data.info;
3812 if (loopspec[n] != NULL)
3814 specinfo = &loopspec[n]->data.info;
3815 spec_dim = specinfo->dim[n];
3819 /* Silence unitialized warnings. */
3826 gcc_assert (ss->shape[dim]);
3827 /* The frontend has worked out the size for us. */
3829 || !loopspec[n]->shape
3830 || !integer_zerop (specinfo->start[spec_dim]))
3831 /* Prefer zero-based descriptors if possible. */
3836 if (ss->type == GFC_SS_CONSTRUCTOR)
3838 gfc_constructor_base base;
3839 /* An unknown size constructor will always be rank one.
3840 Higher rank constructors will either have known shape,
3841 or still be wrapped in a call to reshape. */
3842 gcc_assert (loop->dimen == 1);
3844 /* Always prefer to use the constructor bounds if the size
3845 can be determined at compile time. Prefer not to otherwise,
3846 since the general case involves realloc, and it's better to
3847 avoid that overhead if possible. */
3848 base = ss->expr->value.constructor;
3849 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3850 if (!dynamic[n] || !loopspec[n])
3855 /* TODO: Pick the best bound if we have a choice between a
3856 function and something else. */
3857 if (ss->type == GFC_SS_FUNCTION)
3863 /* Avoid using an allocatable lhs in an assignment, since
3864 there might be a reallocation coming. */
3865 if (loopspec[n] && ss->is_alloc_lhs)
3868 if (ss->type != GFC_SS_SECTION)
3873 /* Criteria for choosing a loop specifier (most important first):
3874 doesn't need realloc
3880 else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3881 || n >= loop->dimen)
3883 else if (integer_onep (info->stride[dim])
3884 && !integer_onep (specinfo->stride[spec_dim]))
3886 else if (INTEGER_CST_P (info->stride[dim])
3887 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3889 else if (INTEGER_CST_P (info->start[dim])
3890 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3892 /* We don't work out the upper bound.
3893 else if (INTEGER_CST_P (info->finish[n])
3894 && ! INTEGER_CST_P (specinfo->finish[n]))
3895 loopspec[n] = ss; */
3898 /* We should have found the scalarization loop specifier. If not,
3900 gcc_assert (loopspec[n]);
3902 info = &loopspec[n]->data.info;
3905 /* Set the extents of this range. */
3906 cshape = loopspec[n]->shape;
3907 if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
3908 && INTEGER_CST_P (info->stride[dim]))
3910 loop->from[n] = info->start[dim];
3911 mpz_set (i, cshape[get_array_ref_dim (info, n)]);
3912 mpz_sub_ui (i, i, 1);
3913 /* To = from + (size - 1) * stride. */
3914 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3915 if (!integer_onep (info->stride[dim]))
3916 tmp = fold_build2_loc (input_location, MULT_EXPR,
3917 gfc_array_index_type, tmp,
3919 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
3920 gfc_array_index_type,
3921 loop->from[n], tmp);
3925 loop->from[n] = info->start[dim];
3926 switch (loopspec[n]->type)
3928 case GFC_SS_CONSTRUCTOR:
3929 /* The upper bound is calculated when we expand the
3931 gcc_assert (loop->to[n] == NULL_TREE);
3934 case GFC_SS_SECTION:
3935 /* Use the end expression if it exists and is not constant,
3936 so that it is only evaluated once. */
3937 loop->to[n] = info->end[dim];
3940 case GFC_SS_FUNCTION:
3941 /* The loop bound will be set when we generate the call. */
3942 gcc_assert (loop->to[n] == NULL_TREE);
3950 /* Transform everything so we have a simple incrementing variable. */
3951 if (n < loop->dimen && integer_onep (info->stride[dim]))
3952 info->delta[dim] = gfc_index_zero_node;
3953 else if (n < loop->dimen)
3955 /* Set the delta for this section. */
3956 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
3957 /* Number of iterations is (end - start + step) / step.
3958 with start = 0, this simplifies to
3960 for (i = 0; i<=last; i++){...}; */
3961 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3962 gfc_array_index_type, loop->to[n],
3964 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3965 gfc_array_index_type, tmp, info->stride[dim]);
3966 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
3967 tmp, build_int_cst (gfc_array_index_type, -1));
3968 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3969 /* Make the loop variable start at 0. */
3970 loop->from[n] = gfc_index_zero_node;
3974 /* Add all the scalar code that can be taken out of the loops.
3975 This may include calculating the loop bounds, so do it before
3976 allocating the temporary. */
3977 gfc_add_loop_ss_code (loop, loop->ss, false, where);
3979 /* If we want a temporary then create it. */
3980 if (loop->temp_ss != NULL)
3982 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3984 /* Make absolutely sure that this is a complete type. */
3985 if (loop->temp_ss->string_length)
3986 loop->temp_ss->data.temp.type
3987 = gfc_get_character_type_len_for_eltype
3988 (TREE_TYPE (loop->temp_ss->data.temp.type),
3989 loop->temp_ss->string_length);
3991 tmp = loop->temp_ss->data.temp.type;
3992 n = loop->temp_ss->data.temp.dimen;
3993 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3994 loop->temp_ss->type = GFC_SS_SECTION;
3995 loop->temp_ss->data.info.dimen = n;
3997 gcc_assert (loop->temp_ss->data.info.dimen != 0);
3998 for (n = 0; n < loop->temp_ss->data.info.dimen; n++)
3999 loop->temp_ss->data.info.dim[n] = n;
4001 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4002 &loop->temp_ss->data.info, tmp, NULL_TREE,
4003 false, true, false, where);
4006 for (n = 0; n < loop->temp_dim; n++)
4007 loopspec[loop->order[n]] = NULL;
4011 /* For array parameters we don't have loop variables, so don't calculate the
4013 if (loop->array_parameter)
4016 /* Calculate the translation from loop variables to array indices. */
4017 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4019 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
4020 && ss->type != GFC_SS_CONSTRUCTOR)
4024 info = &ss->data.info;
4026 for (n = 0; n < info->dimen; n++)
4028 /* If we are specifying the range the delta is already set. */
4029 if (loopspec[n] != ss)
4031 dim = ss->data.info.dim[n];
4033 /* Calculate the offset relative to the loop variable.
4034 First multiply by the stride. */
4035 tmp = loop->from[n];
4036 if (!integer_onep (info->stride[dim]))
4037 tmp = fold_build2_loc (input_location, MULT_EXPR,
4038 gfc_array_index_type,
4039 tmp, info->stride[dim]);
4041 /* Then subtract this from our starting value. */
4042 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4043 gfc_array_index_type,
4044 info->start[dim], tmp);
4046 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4053 /* Calculate the size of a given array dimension from the bounds. This
4054 is simply (ubound - lbound + 1) if this expression is positive
4055 or 0 if it is negative (pick either one if it is zero). Optionally
4056 (if or_expr is present) OR the (expression != 0) condition to it. */
4059 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4064 /* Calculate (ubound - lbound + 1). */
4065 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4067 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4068 gfc_index_one_node);
4070 /* Check whether the size for this dimension is negative. */
4071 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4072 gfc_index_zero_node);
4073 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4074 gfc_index_zero_node, res);
4076 /* Build OR expression. */
4078 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4079 boolean_type_node, *or_expr, cond);
4085 /* For an array descriptor, get the total number of elements. This is just
4086 the product of the extents along from_dim to to_dim. */
4089 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4094 res = gfc_index_one_node;
4096 for (dim = from_dim; dim < to_dim; ++dim)
4102 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4103 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4105 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4106 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4114 /* Full size of an array. */
4117 gfc_conv_descriptor_size (tree desc, int rank)
4119 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4123 /* Size of a coarray for all dimensions but the last. */
4126 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4128 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4132 /* Fills in an array descriptor, and returns the size of the array.
4133 The size will be a simple_val, ie a variable or a constant. Also
4134 calculates the offset of the base. The pointer argument overflow,
4135 which should be of integer type, will increase in value if overflow
4136 occurs during the size calculation. Returns the size of the array.
4140 for (n = 0; n < rank; n++)
4142 a.lbound[n] = specified_lower_bound;
4143 offset = offset + a.lbond[n] * stride;
4145 a.ubound[n] = specified_upper_bound;
4146 a.stride[n] = stride;
4147 size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4148 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4149 stride = stride * size;
4151 for (n = rank; n < rank+corank; n++)
4152 (Set lcobound/ucobound as above.)
4153 element_size = sizeof (array element);
4156 stride = (size_t) stride;
4157 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4158 stride = stride * element_size;
4164 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4165 gfc_expr ** lower, gfc_expr ** upper,
4166 stmtblock_t * pblock, tree * overflow)
4179 stmtblock_t thenblock;
4180 stmtblock_t elseblock;
4185 type = TREE_TYPE (descriptor);
4187 stride = gfc_index_one_node;
4188 offset = gfc_index_zero_node;
4190 /* Set the dtype. */
4191 tmp = gfc_conv_descriptor_dtype (descriptor);
4192 gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4194 or_expr = boolean_false_node;
4196 for (n = 0; n < rank; n++)
4201 /* We have 3 possibilities for determining the size of the array:
4202 lower == NULL => lbound = 1, ubound = upper[n]
4203 upper[n] = NULL => lbound = 1, ubound = lower[n]
4204 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4207 /* Set lower bound. */
4208 gfc_init_se (&se, NULL);
4210 se.expr = gfc_index_one_node;
4213 gcc_assert (lower[n]);
4216 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4217 gfc_add_block_to_block (pblock, &se.pre);
4221 se.expr = gfc_index_one_node;
4225 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4227 conv_lbound = se.expr;
4229 /* Work out the offset for this component. */
4230 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4232 offset = fold_build2_loc (input_location, MINUS_EXPR,
4233 gfc_array_index_type, offset, tmp);
4235 /* Set upper bound. */
4236 gfc_init_se (&se, NULL);
4237 gcc_assert (ubound);
4238 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4239 gfc_add_block_to_block (pblock, &se.pre);
4241 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4242 gfc_rank_cst[n], se.expr);
4243 conv_ubound = se.expr;
4245 /* Store the stride. */
4246 gfc_conv_descriptor_stride_set (pblock, descriptor,
4247 gfc_rank_cst[n], stride);
4249 /* Calculate size and check whether extent is negative. */
4250 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4251 size = gfc_evaluate_now (size, pblock);
4253 /* Check whether multiplying the stride by the number of
4254 elements in this dimension would overflow. We must also check
4255 whether the current dimension has zero size in order to avoid
4258 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4259 gfc_array_index_type,
4260 fold_convert (gfc_array_index_type,
4261 TYPE_MAX_VALUE (gfc_array_index_type)),
4263 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4264 boolean_type_node, tmp, stride));
4265 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4266 integer_one_node, integer_zero_node);
4267 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4268 boolean_type_node, size,
4269 gfc_index_zero_node));
4270 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4271 integer_zero_node, tmp);
4272 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4274 *overflow = gfc_evaluate_now (tmp, pblock);
4276 /* Multiply the stride by the number of elements in this dimension. */
4277 stride = fold_build2_loc (input_location, MULT_EXPR,
4278 gfc_array_index_type, stride, size);
4279 stride = gfc_evaluate_now (stride, pblock);
4282 for (n = rank; n < rank + corank; n++)
4286 /* Set lower bound. */
4287 gfc_init_se (&se, NULL);
4288 if (lower == NULL || lower[n] == NULL)
4290 gcc_assert (n == rank + corank - 1);
4291 se.expr = gfc_index_one_node;
4295 if (ubound || n == rank + corank - 1)
4297 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4298 gfc_add_block_to_block (pblock, &se.pre);
4302 se.expr = gfc_index_one_node;
4306 gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
4309 if (n < rank + corank - 1)
4311 gfc_init_se (&se, NULL);
4312 gcc_assert (ubound);
4313 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4314 gfc_add_block_to_block (pblock, &se.pre);
4315 gfc_conv_descriptor_ubound_set (pblock, descriptor,
4316 gfc_rank_cst[n], se.expr);
4320 /* The stride is the number of elements in the array, so multiply by the
4321 size of an element to get the total size. */
4322 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4323 /* Convert to size_t. */
4324 element_size = fold_convert (size_type_node, tmp);
4327 return element_size;
4329 stride = fold_convert (size_type_node, stride);
4331 /* First check for overflow. Since an array of type character can
4332 have zero element_size, we must check for that before
4334 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4336 TYPE_MAX_VALUE (size_type_node), element_size);
4337 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4338 boolean_type_node, tmp, stride));
4339 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4340 integer_one_node, integer_zero_node);
4341 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4342 boolean_type_node, element_size,
4343 build_int_cst (size_type_node, 0)));
4344 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4345 integer_zero_node, tmp);
4346 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4348 *overflow = gfc_evaluate_now (tmp, pblock);
4350 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4351 stride, element_size);
4353 if (poffset != NULL)
4355 offset = gfc_evaluate_now (offset, pblock);
4359 if (integer_zerop (or_expr))
4361 if (integer_onep (or_expr))
4362 return build_int_cst (size_type_node, 0);
4364 var = gfc_create_var (TREE_TYPE (size), "size");
4365 gfc_start_block (&thenblock);
4366 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4367 thencase = gfc_finish_block (&thenblock);
4369 gfc_start_block (&elseblock);
4370 gfc_add_modify (&elseblock, var, size);
4371 elsecase = gfc_finish_block (&elseblock);
4373 tmp = gfc_evaluate_now (or_expr, pblock);
4374 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4375 gfc_add_expr_to_block (pblock, tmp);
4381 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4382 the work for an ALLOCATE statement. */
4386 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4391 tree offset = NULL_TREE;
4394 tree error = NULL_TREE;
4395 tree overflow; /* Boolean storing whether size calculation overflows. */
4396 tree var_overflow = NULL_TREE;
4398 stmtblock_t elseblock;
4401 gfc_ref *ref, *prev_ref = NULL;
4402 bool allocatable, coarray, dimension;
4406 /* Find the last reference in the chain. */
4407 while (ref && ref->next != NULL)
4409 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4410 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4415 if (ref == NULL || ref->type != REF_ARRAY)
4420 allocatable = expr->symtree->n.sym->attr.allocatable;
4421 coarray = expr->symtree->n.sym->attr.codimension;
4422 dimension = expr->symtree->n.sym->attr.dimension;
4426 allocatable = prev_ref->u.c.component->attr.allocatable;
4427 coarray = prev_ref->u.c.component->attr.codimension;
4428 dimension = prev_ref->u.c.component->attr.dimension;
4432 gcc_assert (coarray);
4434 /* Figure out the size of the array. */
4435 switch (ref->u.ar.type)
4441 upper = ref->u.ar.start;
4447 lower = ref->u.ar.start;
4448 upper = ref->u.ar.end;
4452 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4454 lower = ref->u.ar.as->lower;
4455 upper = ref->u.ar.as->upper;
4463 overflow = integer_zero_node;
4464 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4465 ref->u.ar.as->corank, &offset, lower, upper,
4466 &se->pre, &overflow);
4470 var_overflow = gfc_create_var (integer_type_node, "overflow");
4471 gfc_add_modify (&se->pre, var_overflow, overflow);
4473 /* Generate the block of code handling overflow. */
4474 msg = gfc_build_addr_expr (pchar_type_node,
4475 gfc_build_localized_cstring_const
4476 ("Integer overflow when calculating the amount of "
4477 "memory to allocate"));
4478 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4482 if (status != NULL_TREE)
4484 tree status_type = TREE_TYPE (status);
4485 stmtblock_t set_status_block;
4487 gfc_start_block (&set_status_block);
4488 gfc_add_modify (&set_status_block, status,
4489 build_int_cst (status_type, LIBERROR_ALLOCATION));
4490 error = gfc_finish_block (&set_status_block);
4493 gfc_start_block (&elseblock);
4495 /* Allocate memory to store the data. */
4496 pointer = gfc_conv_descriptor_data_get (se->expr);
4497 STRIP_NOPS (pointer);
4499 /* The allocatable variant takes the old pointer as first argument. */
4501 tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
4502 status, errmsg, errlen, expr);
4504 tmp = gfc_allocate_using_malloc (&elseblock, size, status);
4506 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4509 gfc_add_expr_to_block (&elseblock, tmp);
4513 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4514 boolean_type_node, var_overflow, integer_zero_node));
4515 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4516 error, gfc_finish_block (&elseblock));
4519 tmp = gfc_finish_block (&elseblock);
4521 gfc_add_expr_to_block (&se->pre, tmp);
4524 gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
4526 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4527 && expr->ts.u.derived->attr.alloc_comp)
4529 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4530 ref->u.ar.as->rank);
4531 gfc_add_expr_to_block (&se->pre, tmp);
4538 /* Deallocate an array variable. Also used when an allocated variable goes
4543 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4549 gfc_start_block (&block);
4550 /* Get a pointer to the data. */
4551 var = gfc_conv_descriptor_data_get (descriptor);
4554 /* Parameter is the address of the data component. */
4555 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4556 gfc_add_expr_to_block (&block, tmp);
4558 /* Zero the data pointer. */
4559 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4560 var, build_int_cst (TREE_TYPE (var), 0));
4561 gfc_add_expr_to_block (&block, tmp);
4563 return gfc_finish_block (&block);
4567 /* Create an array constructor from an initialization expression.
4568 We assume the frontend already did any expansions and conversions. */
4571 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4577 unsigned HOST_WIDE_INT lo;
4579 VEC(constructor_elt,gc) *v = NULL;
4581 switch (expr->expr_type)
4584 case EXPR_STRUCTURE:
4585 /* A single scalar or derived type value. Create an array with all
4586 elements equal to that value. */
4587 gfc_init_se (&se, NULL);
4589 if (expr->expr_type == EXPR_CONSTANT)
4590 gfc_conv_constant (&se, expr);
4592 gfc_conv_structure (&se, expr, 1);
4594 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4595 gcc_assert (tmp && INTEGER_CST_P (tmp));
4596 hi = TREE_INT_CST_HIGH (tmp);
4597 lo = TREE_INT_CST_LOW (tmp);
4601 /* This will probably eat buckets of memory for large arrays. */
4602 while (hi != 0 || lo != 0)
4604 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4612 /* Create a vector of all the elements. */
4613 for (c = gfc_constructor_first (expr->value.constructor);
4614 c; c = gfc_constructor_next (c))
4618 /* Problems occur when we get something like
4619 integer :: a(lots) = (/(i, i=1, lots)/) */
4620 gfc_fatal_error ("The number of elements in the array constructor "
4621 "at %L requires an increase of the allowed %d "
4622 "upper limit. See -fmax-array-constructor "
4623 "option", &expr->where,
4624 gfc_option.flag_max_array_constructor);
4627 if (mpz_cmp_si (c->offset, 0) != 0)
4628 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4632 if (mpz_cmp_si (c->repeat, 1) > 0)
4638 mpz_add (maxval, c->offset, c->repeat);
4639 mpz_sub_ui (maxval, maxval, 1);
4640 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4641 if (mpz_cmp_si (c->offset, 0) != 0)
4643 mpz_add_ui (maxval, c->offset, 1);
4644 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4647 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4649 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4655 gfc_init_se (&se, NULL);
4656 switch (c->expr->expr_type)
4659 gfc_conv_constant (&se, c->expr);
4662 case EXPR_STRUCTURE:
4663 gfc_conv_structure (&se, c->expr, 1);
4667 /* Catch those occasional beasts that do not simplify
4668 for one reason or another, assuming that if they are
4669 standard defying the frontend will catch them. */
4670 gfc_conv_expr (&se, c->expr);
4674 if (range == NULL_TREE)
4675 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4678 if (index != NULL_TREE)
4679 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4680 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4686 return gfc_build_null_descriptor (type);
4692 /* Create a constructor from the list of elements. */
4693 tmp = build_constructor (type, v);
4694 TREE_CONSTANT (tmp) = 1;
4699 /* Generate code to evaluate non-constant coarray cobounds. */
4702 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4703 const gfc_symbol *sym)
4713 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4715 /* Evaluate non-constant array bound expressions. */
4716 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4717 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4719 gfc_init_se (&se, NULL);
4720 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4721 gfc_add_block_to_block (pblock, &se.pre);
4722 gfc_add_modify (pblock, lbound, se.expr);
4724 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4725 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4727 gfc_init_se (&se, NULL);
4728 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4729 gfc_add_block_to_block (pblock, &se.pre);
4730 gfc_add_modify (pblock, ubound, se.expr);
4736 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4737 returns the size (in elements) of the array. */
4740 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4741 stmtblock_t * pblock)
4756 size = gfc_index_one_node;
4757 offset = gfc_index_zero_node;
4758 for (dim = 0; dim < as->rank; dim++)
4760 /* Evaluate non-constant array bound expressions. */
4761 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4762 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4764 gfc_init_se (&se, NULL);
4765 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4766 gfc_add_block_to_block (pblock, &se.pre);
4767 gfc_add_modify (pblock, lbound, se.expr);
4769 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4770 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4772 gfc_init_se (&se, NULL);
4773 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4774 gfc_add_block_to_block (pblock, &se.pre);
4775 gfc_add_modify (pblock, ubound, se.expr);
4777 /* The offset of this dimension. offset = offset - lbound * stride. */
4778 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4780 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4783 /* The size of this dimension, and the stride of the next. */
4784 if (dim + 1 < as->rank)
4785 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4787 stride = GFC_TYPE_ARRAY_SIZE (type);
4789 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4791 /* Calculate stride = size * (ubound + 1 - lbound). */
4792 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4793 gfc_array_index_type,
4794 gfc_index_one_node, lbound);
4795 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4796 gfc_array_index_type, ubound, tmp);
4797 tmp = fold_build2_loc (input_location, MULT_EXPR,
4798 gfc_array_index_type, size, tmp);
4800 gfc_add_modify (pblock, stride, tmp);
4802 stride = gfc_evaluate_now (tmp, pblock);
4804 /* Make sure that negative size arrays are translated
4805 to being zero size. */
4806 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4807 stride, gfc_index_zero_node);
4808 tmp = fold_build3_loc (input_location, COND_EXPR,
4809 gfc_array_index_type, tmp,
4810 stride, gfc_index_zero_node);
4811 gfc_add_modify (pblock, stride, tmp);
4817 gfc_trans_array_cobounds (type, pblock, sym);
4818 gfc_trans_vla_type_sizes (sym, pblock);
4825 /* Generate code to initialize/allocate an array variable. */
4828 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4829 gfc_wrapped_block * block)
4833 tree tmp = NULL_TREE;
4840 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4842 /* Do nothing for USEd variables. */
4843 if (sym->attr.use_assoc)
4846 type = TREE_TYPE (decl);
4847 gcc_assert (GFC_ARRAY_TYPE_P (type));
4848 onstack = TREE_CODE (type) != POINTER_TYPE;
4850 gfc_start_block (&init);
4852 /* Evaluate character string length. */
4853 if (sym->ts.type == BT_CHARACTER
4854 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4856 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4858 gfc_trans_vla_type_sizes (sym, &init);
4860 /* Emit a DECL_EXPR for this variable, which will cause the
4861 gimplifier to allocate storage, and all that good stuff. */
4862 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4863 gfc_add_expr_to_block (&init, tmp);
4868 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4872 type = TREE_TYPE (type);
4874 gcc_assert (!sym->attr.use_assoc);
4875 gcc_assert (!TREE_STATIC (decl));
4876 gcc_assert (!sym->module);
4878 if (sym->ts.type == BT_CHARACTER
4879 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4880 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4882 size = gfc_trans_array_bounds (type, sym, &offset, &init);
4884 /* Don't actually allocate space for Cray Pointees. */
4885 if (sym->attr.cray_pointee)
4887 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4888 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4890 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4894 if (gfc_option.flag_stack_arrays)
4896 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
4897 space = build_decl (sym->declared_at.lb->location,
4898 VAR_DECL, create_tmp_var_name ("A"),
4899 TREE_TYPE (TREE_TYPE (decl)));
4900 gfc_trans_vla_type_sizes (sym, &init);
4904 /* The size is the number of elements in the array, so multiply by the
4905 size of an element to get the total size. */
4906 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4907 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4908 size, fold_convert (gfc_array_index_type, tmp));
4910 /* Allocate memory to hold the data. */
4911 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
4912 gfc_add_modify (&init, decl, tmp);
4914 /* Free the temporary. */
4915 tmp = gfc_call_free (convert (pvoid_type_node, decl));
4919 /* Set offset of the array. */
4920 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4921 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4923 /* Automatic arrays should not have initializers. */
4924 gcc_assert (!sym->value);
4926 inittree = gfc_finish_block (&init);
4933 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
4934 where also space is located. */
4935 gfc_init_block (&init);
4936 tmp = fold_build1_loc (input_location, DECL_EXPR,
4937 TREE_TYPE (space), space);
4938 gfc_add_expr_to_block (&init, tmp);
4939 addr = fold_build1_loc (sym->declared_at.lb->location,
4940 ADDR_EXPR, TREE_TYPE (decl), space);
4941 gfc_add_modify (&init, decl, addr);
4942 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4945 gfc_add_init_cleanup (block, inittree, tmp);
4949 /* Generate entry and exit code for g77 calling convention arrays. */
4952 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
4962 gfc_save_backend_locus (&loc);
4963 gfc_set_backend_locus (&sym->declared_at);
4965 /* Descriptor type. */
4966 parm = sym->backend_decl;
4967 type = TREE_TYPE (parm);
4968 gcc_assert (GFC_ARRAY_TYPE_P (type));
4970 gfc_start_block (&init);
4972 if (sym->ts.type == BT_CHARACTER
4973 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4974 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4976 /* Evaluate the bounds of the array. */
4977 gfc_trans_array_bounds (type, sym, &offset, &init);
4979 /* Set the offset. */
4980 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
4981 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
4983 /* Set the pointer itself if we aren't using the parameter directly. */
4984 if (TREE_CODE (parm) != PARM_DECL)
4986 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
4987 gfc_add_modify (&init, parm, tmp);
4989 stmt = gfc_finish_block (&init);
4991 gfc_restore_backend_locus (&loc);
4993 /* Add the initialization code to the start of the function. */
4995 if (sym->attr.optional || sym->attr.not_always_present)
4997 tmp = gfc_conv_expr_present (sym);
4998 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5001 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5005 /* Modify the descriptor of an array parameter so that it has the
5006 correct lower bound. Also move the upper bound accordingly.
5007 If the array is not packed, it will be copied into a temporary.
5008 For each dimension we set the new lower and upper bounds. Then we copy the
5009 stride and calculate the offset for this dimension. We also work out
5010 what the stride of a packed array would be, and see it the two match.
5011 If the array need repacking, we set the stride to the values we just
5012 calculated, recalculate the offset and copy the array data.
5013 Code is also added to copy the data back at the end of the function.
5017 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5018 gfc_wrapped_block * block)
5025 tree stmtInit, stmtCleanup;
5032 tree stride, stride2;
5042 /* Do nothing for pointer and allocatable arrays. */
5043 if (sym->attr.pointer || sym->attr.allocatable)
5046 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5048 gfc_trans_g77_array (sym, block);
5052 gfc_save_backend_locus (&loc);
5053 gfc_set_backend_locus (&sym->declared_at);
5055 /* Descriptor type. */
5056 type = TREE_TYPE (tmpdesc);
5057 gcc_assert (GFC_ARRAY_TYPE_P (type));
5058 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5059 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5060 gfc_start_block (&init);
5062 if (sym->ts.type == BT_CHARACTER
5063 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5064 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5066 checkparm = (sym->as->type == AS_EXPLICIT
5067 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5069 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5070 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5072 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5074 /* For non-constant shape arrays we only check if the first dimension
5075 is contiguous. Repacking higher dimensions wouldn't gain us
5076 anything as we still don't know the array stride. */
5077 partial = gfc_create_var (boolean_type_node, "partial");
5078 TREE_USED (partial) = 1;
5079 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5080 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5081 gfc_index_one_node);
5082 gfc_add_modify (&init, partial, tmp);
5085 partial = NULL_TREE;
5087 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5088 here, however I think it does the right thing. */
5091 /* Set the first stride. */
5092 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5093 stride = gfc_evaluate_now (stride, &init);
5095 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5096 stride, gfc_index_zero_node);
5097 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5098 tmp, gfc_index_one_node, stride);
5099 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5100 gfc_add_modify (&init, stride, tmp);
5102 /* Allow the user to disable array repacking. */
5103 stmt_unpacked = NULL_TREE;
5107 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5108 /* A library call to repack the array if necessary. */
5109 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5110 stmt_unpacked = build_call_expr_loc (input_location,
5111 gfor_fndecl_in_pack, 1, tmp);
5113 stride = gfc_index_one_node;
5115 if (gfc_option.warn_array_temp)
5116 gfc_warning ("Creating array temporary at %L", &loc);
5119 /* This is for the case where the array data is used directly without
5120 calling the repack function. */
5121 if (no_repack || partial != NULL_TREE)
5122 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5124 stmt_packed = NULL_TREE;
5126 /* Assign the data pointer. */
5127 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5129 /* Don't repack unknown shape arrays when the first stride is 1. */
5130 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5131 partial, stmt_packed, stmt_unpacked);
5134 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5135 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5137 offset = gfc_index_zero_node;
5138 size = gfc_index_one_node;
5140 /* Evaluate the bounds of the array. */
5141 for (n = 0; n < sym->as->rank; n++)
5143 if (checkparm || !sym->as->upper[n])
5145 /* Get the bounds of the actual parameter. */
5146 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5147 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5151 dubound = NULL_TREE;
5152 dlbound = NULL_TREE;
5155 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5156 if (!INTEGER_CST_P (lbound))
5158 gfc_init_se (&se, NULL);
5159 gfc_conv_expr_type (&se, sym->as->lower[n],
5160 gfc_array_index_type);
5161 gfc_add_block_to_block (&init, &se.pre);
5162 gfc_add_modify (&init, lbound, se.expr);
5165 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5166 /* Set the desired upper bound. */
5167 if (sym->as->upper[n])
5169 /* We know what we want the upper bound to be. */
5170 if (!INTEGER_CST_P (ubound))
5172 gfc_init_se (&se, NULL);
5173 gfc_conv_expr_type (&se, sym->as->upper[n],
5174 gfc_array_index_type);
5175 gfc_add_block_to_block (&init, &se.pre);
5176 gfc_add_modify (&init, ubound, se.expr);
5179 /* Check the sizes match. */
5182 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5186 temp = fold_build2_loc (input_location, MINUS_EXPR,
5187 gfc_array_index_type, ubound, lbound);
5188 temp = fold_build2_loc (input_location, PLUS_EXPR,
5189 gfc_array_index_type,
5190 gfc_index_one_node, temp);
5191 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5192 gfc_array_index_type, dubound,
5194 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5195 gfc_array_index_type,
5196 gfc_index_one_node, stride2);
5197 tmp = fold_build2_loc (input_location, NE_EXPR,
5198 gfc_array_index_type, temp, stride2);
5199 asprintf (&msg, "Dimension %d of array '%s' has extent "
5200 "%%ld instead of %%ld", n+1, sym->name);
5202 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5203 fold_convert (long_integer_type_node, temp),
5204 fold_convert (long_integer_type_node, stride2));
5211 /* For assumed shape arrays move the upper bound by the same amount
5212 as the lower bound. */
5213 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5214 gfc_array_index_type, dubound, dlbound);
5215 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5216 gfc_array_index_type, tmp, lbound);
5217 gfc_add_modify (&init, ubound, tmp);
5219 /* The offset of this dimension. offset = offset - lbound * stride. */
5220 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5222 offset = fold_build2_loc (input_location, MINUS_EXPR,
5223 gfc_array_index_type, offset, tmp);
5225 /* The size of this dimension, and the stride of the next. */
5226 if (n + 1 < sym->as->rank)
5228 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5230 if (no_repack || partial != NULL_TREE)
5232 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5234 /* Figure out the stride if not a known constant. */
5235 if (!INTEGER_CST_P (stride))
5238 stmt_packed = NULL_TREE;
5241 /* Calculate stride = size * (ubound + 1 - lbound). */
5242 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5243 gfc_array_index_type,
5244 gfc_index_one_node, lbound);
5245 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5246 gfc_array_index_type, ubound, tmp);
5247 size = fold_build2_loc (input_location, MULT_EXPR,
5248 gfc_array_index_type, size, tmp);
5252 /* Assign the stride. */
5253 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5254 tmp = fold_build3_loc (input_location, COND_EXPR,
5255 gfc_array_index_type, partial,
5256 stmt_unpacked, stmt_packed);
5258 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5259 gfc_add_modify (&init, stride, tmp);
5264 stride = GFC_TYPE_ARRAY_SIZE (type);
5266 if (stride && !INTEGER_CST_P (stride))
5268 /* Calculate size = stride * (ubound + 1 - lbound). */
5269 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5270 gfc_array_index_type,
5271 gfc_index_one_node, lbound);
5272 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5273 gfc_array_index_type,
5275 tmp = fold_build2_loc (input_location, MULT_EXPR,
5276 gfc_array_index_type,
5277 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5278 gfc_add_modify (&init, stride, tmp);
5283 gfc_trans_array_cobounds (type, &init, sym);
5285 /* Set the offset. */
5286 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5287 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5289 gfc_trans_vla_type_sizes (sym, &init);
5291 stmtInit = gfc_finish_block (&init);
5293 /* Only do the entry/initialization code if the arg is present. */
5294 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5295 optional_arg = (sym->attr.optional
5296 || (sym->ns->proc_name->attr.entry_master
5297 && sym->attr.dummy));
5300 tmp = gfc_conv_expr_present (sym);
5301 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5302 build_empty_stmt (input_location));
5307 stmtCleanup = NULL_TREE;
5310 stmtblock_t cleanup;
5311 gfc_start_block (&cleanup);
5313 if (sym->attr.intent != INTENT_IN)
5315 /* Copy the data back. */
5316 tmp = build_call_expr_loc (input_location,
5317 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5318 gfc_add_expr_to_block (&cleanup, tmp);
5321 /* Free the temporary. */
5322 tmp = gfc_call_free (tmpdesc);
5323 gfc_add_expr_to_block (&cleanup, tmp);
5325 stmtCleanup = gfc_finish_block (&cleanup);
5327 /* Only do the cleanup if the array was repacked. */
5328 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5329 tmp = gfc_conv_descriptor_data_get (tmp);
5330 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5332 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5333 build_empty_stmt (input_location));
5337 tmp = gfc_conv_expr_present (sym);
5338 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5339 build_empty_stmt (input_location));
5343 /* We don't need to free any memory allocated by internal_pack as it will
5344 be freed at the end of the function by pop_context. */
5345 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5347 gfc_restore_backend_locus (&loc);
5351 /* Calculate the overall offset, including subreferences. */
5353 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5354 bool subref, gfc_expr *expr)
5364 /* If offset is NULL and this is not a subreferenced array, there is
5366 if (offset == NULL_TREE)
5369 offset = gfc_index_zero_node;
5374 tmp = gfc_conv_array_data (desc);
5375 tmp = build_fold_indirect_ref_loc (input_location,
5377 tmp = gfc_build_array_ref (tmp, offset, NULL);
5379 /* Offset the data pointer for pointer assignments from arrays with
5380 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5383 /* Go past the array reference. */
5384 for (ref = expr->ref; ref; ref = ref->next)
5385 if (ref->type == REF_ARRAY &&
5386 ref->u.ar.type != AR_ELEMENT)
5392 /* Calculate the offset for each subsequent subreference. */
5393 for (; ref; ref = ref->next)
5398 field = ref->u.c.component->backend_decl;
5399 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5400 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5402 tmp, field, NULL_TREE);
5406 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5407 gfc_init_se (&start, NULL);
5408 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5409 gfc_add_block_to_block (block, &start.pre);
5410 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5414 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5415 && ref->u.ar.type == AR_ELEMENT);
5417 /* TODO - Add bounds checking. */
5418 stride = gfc_index_one_node;
5419 index = gfc_index_zero_node;
5420 for (n = 0; n < ref->u.ar.dimen; n++)
5425 /* Update the index. */
5426 gfc_init_se (&start, NULL);
5427 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5428 itmp = gfc_evaluate_now (start.expr, block);
5429 gfc_init_se (&start, NULL);
5430 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5431 jtmp = gfc_evaluate_now (start.expr, block);
5432 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5433 gfc_array_index_type, itmp, jtmp);
5434 itmp = fold_build2_loc (input_location, MULT_EXPR,
5435 gfc_array_index_type, itmp, stride);
5436 index = fold_build2_loc (input_location, PLUS_EXPR,
5437 gfc_array_index_type, itmp, index);
5438 index = gfc_evaluate_now (index, block);
5440 /* Update the stride. */
5441 gfc_init_se (&start, NULL);
5442 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5443 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5444 gfc_array_index_type, start.expr,
5446 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5447 gfc_array_index_type,
5448 gfc_index_one_node, itmp);
5449 stride = fold_build2_loc (input_location, MULT_EXPR,
5450 gfc_array_index_type, stride, itmp);
5451 stride = gfc_evaluate_now (stride, block);
5454 /* Apply the index to obtain the array element. */
5455 tmp = gfc_build_array_ref (tmp, index, NULL);
5465 /* Set the target data pointer. */
5466 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5467 gfc_conv_descriptor_data_set (block, parm, offset);
5471 /* gfc_conv_expr_descriptor needs the string length an expression
5472 so that the size of the temporary can be obtained. This is done
5473 by adding up the string lengths of all the elements in the
5474 expression. Function with non-constant expressions have their
5475 string lengths mapped onto the actual arguments using the
5476 interface mapping machinery in trans-expr.c. */
5478 get_array_charlen (gfc_expr *expr, gfc_se *se)
5480 gfc_interface_mapping mapping;
5481 gfc_formal_arglist *formal;
5482 gfc_actual_arglist *arg;
5485 if (expr->ts.u.cl->length
5486 && gfc_is_constant_expr (expr->ts.u.cl->length))
5488 if (!expr->ts.u.cl->backend_decl)
5489 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5493 switch (expr->expr_type)
5496 get_array_charlen (expr->value.op.op1, se);
5498 /* For parentheses the expression ts.u.cl is identical. */
5499 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5502 expr->ts.u.cl->backend_decl =
5503 gfc_create_var (gfc_charlen_type_node, "sln");
5505 if (expr->value.op.op2)
5507 get_array_charlen (expr->value.op.op2, se);
5509 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5511 /* Add the string lengths and assign them to the expression
5512 string length backend declaration. */
5513 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5514 fold_build2_loc (input_location, PLUS_EXPR,
5515 gfc_charlen_type_node,
5516 expr->value.op.op1->ts.u.cl->backend_decl,
5517 expr->value.op.op2->ts.u.cl->backend_decl));
5520 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5521 expr->value.op.op1->ts.u.cl->backend_decl);
5525 if (expr->value.function.esym == NULL
5526 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5528 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5532 /* Map expressions involving the dummy arguments onto the actual
5533 argument expressions. */
5534 gfc_init_interface_mapping (&mapping);
5535 formal = expr->symtree->n.sym->formal;
5536 arg = expr->value.function.actual;
5538 /* Set se = NULL in the calls to the interface mapping, to suppress any
5540 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5545 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5548 gfc_init_se (&tse, NULL);
5550 /* Build the expression for the character length and convert it. */
5551 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5553 gfc_add_block_to_block (&se->pre, &tse.pre);
5554 gfc_add_block_to_block (&se->post, &tse.post);
5555 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5556 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5557 gfc_charlen_type_node, tse.expr,
5558 build_int_cst (gfc_charlen_type_node, 0));
5559 expr->ts.u.cl->backend_decl = tse.expr;
5560 gfc_free_interface_mapping (&mapping);
5564 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5569 /* Helper function to check dimensions. */
5571 dim_ok (gfc_ss_info *info)
5574 for (n = 0; n < info->dimen; n++)
5575 if (info->dim[n] != n)
5580 /* Convert an array for passing as an actual argument. Expressions and
5581 vector subscripts are evaluated and stored in a temporary, which is then
5582 passed. For whole arrays the descriptor is passed. For array sections
5583 a modified copy of the descriptor is passed, but using the original data.
5585 This function is also used for array pointer assignments, and there
5588 - se->want_pointer && !se->direct_byref
5589 EXPR is an actual argument. On exit, se->expr contains a
5590 pointer to the array descriptor.
5592 - !se->want_pointer && !se->direct_byref
5593 EXPR is an actual argument to an intrinsic function or the
5594 left-hand side of a pointer assignment. On exit, se->expr
5595 contains the descriptor for EXPR.
5597 - !se->want_pointer && se->direct_byref
5598 EXPR is the right-hand side of a pointer assignment and
5599 se->expr is the descriptor for the previously-evaluated
5600 left-hand side. The function creates an assignment from
5604 The se->force_tmp flag disables the non-copying descriptor optimization
5605 that is used for transpose. It may be used in cases where there is an
5606 alias between the transpose argument and another argument in the same
5610 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5622 bool subref_array_target = false;
5625 gcc_assert (ss != NULL);
5626 gcc_assert (ss != gfc_ss_terminator);
5628 /* Special case things we know we can pass easily. */
5629 switch (expr->expr_type)
5632 /* If we have a linear array section, we can pass it directly.
5633 Otherwise we need to copy it into a temporary. */
5635 gcc_assert (ss->type == GFC_SS_SECTION);
5636 gcc_assert (ss->expr == expr);
5637 info = &ss->data.info;
5639 /* Get the descriptor for the array. */
5640 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5641 desc = info->descriptor;
5643 subref_array_target = se->direct_byref && is_subref_array (expr);
5644 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5645 && !subref_array_target;
5652 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5654 /* Create a new descriptor if the array doesn't have one. */
5657 else if (info->ref->u.ar.type == AR_FULL)
5659 else if (se->direct_byref)
5662 full = gfc_full_array_ref_p (info->ref, NULL);
5664 if (full && dim_ok (info))
5666 if (se->direct_byref && !se->byref_noassign)
5668 /* Copy the descriptor for pointer assignments. */
5669 gfc_add_modify (&se->pre, se->expr, desc);
5671 /* Add any offsets from subreferences. */
5672 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5673 subref_array_target, expr);
5675 else if (se->want_pointer)
5677 /* We pass full arrays directly. This means that pointers and
5678 allocatable arrays should also work. */
5679 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5686 if (expr->ts.type == BT_CHARACTER)
5687 se->string_length = gfc_get_expr_charlen (expr);
5695 /* We don't need to copy data in some cases. */
5696 arg = gfc_get_noncopying_intrinsic_argument (expr);
5699 /* This is a call to transpose... */
5700 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5701 /* ... which has already been handled by the scalarizer, so
5702 that we just need to get its argument's descriptor. */
5703 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5707 /* A transformational function return value will be a temporary
5708 array descriptor. We still need to go through the scalarizer
5709 to create the descriptor. Elemental functions ar handled as
5710 arbitrary expressions, i.e. copy to a temporary. */
5712 if (se->direct_byref)
5714 gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
5716 /* For pointer assignments pass the descriptor directly. */
5720 gcc_assert (se->ss == ss);
5721 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5722 gfc_conv_expr (se, expr);
5726 if (ss->expr != expr || ss->type != GFC_SS_FUNCTION)
5728 if (ss->expr != expr)
5729 /* Elemental function. */
5730 gcc_assert ((expr->value.function.esym != NULL
5731 && expr->value.function.esym->attr.elemental)
5732 || (expr->value.function.isym != NULL
5733 && expr->value.function.isym->elemental));
5735 gcc_assert (ss->type == GFC_SS_INTRINSIC);
5738 if (expr->ts.type == BT_CHARACTER
5739 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5740 get_array_charlen (expr, se);
5746 /* Transformational function. */
5747 info = &ss->data.info;
5753 /* Constant array constructors don't need a temporary. */
5754 if (ss->type == GFC_SS_CONSTRUCTOR
5755 && expr->ts.type != BT_CHARACTER
5756 && gfc_constant_array_constructor_p (expr->value.constructor))
5759 info = &ss->data.info;
5769 /* Something complicated. Copy it into a temporary. */
5775 /* If we are creating a temporary, we don't need to bother about aliases
5780 gfc_init_loopinfo (&loop);
5782 /* Associate the SS with the loop. */
5783 gfc_add_ss_to_loop (&loop, ss);
5785 /* Tell the scalarizer not to bother creating loop variables, etc. */
5787 loop.array_parameter = 1;
5789 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5790 gcc_assert (!se->direct_byref);
5792 /* Setup the scalarizing loops and bounds. */
5793 gfc_conv_ss_startstride (&loop);
5797 /* Tell the scalarizer to make a temporary. */
5798 loop.temp_ss = gfc_get_ss ();
5799 loop.temp_ss->type = GFC_SS_TEMP;
5800 loop.temp_ss->next = gfc_ss_terminator;
5802 if (expr->ts.type == BT_CHARACTER
5803 && !expr->ts.u.cl->backend_decl)
5804 get_array_charlen (expr, se);
5806 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
5808 if (expr->ts.type == BT_CHARACTER)
5809 loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
5811 loop.temp_ss->string_length = NULL;
5813 se->string_length = loop.temp_ss->string_length;
5814 loop.temp_ss->data.temp.dimen = loop.dimen;
5815 loop.temp_ss->data.temp.codimen = loop.codimen;
5816 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5819 gfc_conv_loop_setup (&loop, & expr->where);
5823 /* Copy into a temporary and pass that. We don't need to copy the data
5824 back because expressions and vector subscripts must be INTENT_IN. */
5825 /* TODO: Optimize passing function return values. */
5829 /* Start the copying loops. */
5830 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5831 gfc_mark_ss_chain_used (ss, 1);
5832 gfc_start_scalarized_body (&loop, &block);
5834 /* Copy each data element. */
5835 gfc_init_se (&lse, NULL);
5836 gfc_copy_loopinfo_to_se (&lse, &loop);
5837 gfc_init_se (&rse, NULL);
5838 gfc_copy_loopinfo_to_se (&rse, &loop);
5840 lse.ss = loop.temp_ss;
5843 gfc_conv_scalarized_array_ref (&lse, NULL);
5844 if (expr->ts.type == BT_CHARACTER)
5846 gfc_conv_expr (&rse, expr);
5847 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5848 rse.expr = build_fold_indirect_ref_loc (input_location,
5852 gfc_conv_expr_val (&rse, expr);
5854 gfc_add_block_to_block (&block, &rse.pre);
5855 gfc_add_block_to_block (&block, &lse.pre);
5857 lse.string_length = rse.string_length;
5858 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5859 expr->expr_type == EXPR_VARIABLE
5860 || expr->expr_type == EXPR_ARRAY, true);
5861 gfc_add_expr_to_block (&block, tmp);
5863 /* Finish the copying loops. */
5864 gfc_trans_scalarizing_loops (&loop, &block);
5866 desc = loop.temp_ss->data.info.descriptor;
5868 else if (expr->expr_type == EXPR_FUNCTION && dim_ok (info))
5870 desc = info->descriptor;
5871 se->string_length = ss->string_length;
5875 /* We pass sections without copying to a temporary. Make a new
5876 descriptor and point it at the section we want. The loop variable
5877 limits will be the limits of the section.
5878 A function may decide to repack the array to speed up access, but
5879 we're not bothered about that here. */
5880 int dim, ndim, codim;
5888 /* Set the string_length for a character array. */
5889 if (expr->ts.type == BT_CHARACTER)
5890 se->string_length = gfc_get_expr_charlen (expr);
5892 desc = info->descriptor;
5893 if (se->direct_byref && !se->byref_noassign)
5895 /* For pointer assignments we fill in the destination. */
5897 parmtype = TREE_TYPE (parm);
5901 /* Otherwise make a new one. */
5902 parmtype = gfc_get_element_type (TREE_TYPE (desc));
5903 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
5904 loop.codimen, loop.from,
5906 GFC_ARRAY_UNKNOWN, false);
5907 parm = gfc_create_var (parmtype, "parm");
5910 offset = gfc_index_zero_node;
5912 /* The following can be somewhat confusing. We have two
5913 descriptors, a new one and the original array.
5914 {parm, parmtype, dim} refer to the new one.
5915 {desc, type, n, loop} refer to the original, which maybe
5916 a descriptorless array.
5917 The bounds of the scalarization are the bounds of the section.
5918 We don't have to worry about numeric overflows when calculating
5919 the offsets because all elements are within the array data. */
5921 /* Set the dtype. */
5922 tmp = gfc_conv_descriptor_dtype (parm);
5923 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
5925 /* Set offset for assignments to pointer only to zero if it is not
5927 if (se->direct_byref
5928 && info->ref && info->ref->u.ar.type != AR_FULL)
5929 base = gfc_index_zero_node;
5930 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5931 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
5935 ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
5936 codim = info->codimen;
5937 for (n = 0; n < ndim; n++)
5939 stride = gfc_conv_array_stride (desc, n);
5941 /* Work out the offset. */
5943 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5945 gcc_assert (info->subscript[n]
5946 && info->subscript[n]->type == GFC_SS_SCALAR);
5947 start = info->subscript[n]->data.scalar.expr;
5951 /* Evaluate and remember the start of the section. */
5952 start = info->start[n];
5953 stride = gfc_evaluate_now (stride, &loop.pre);
5956 tmp = gfc_conv_array_lbound (desc, n);
5957 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5959 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
5961 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
5965 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
5967 /* For elemental dimensions, we only need the offset. */
5971 /* Vector subscripts need copying and are handled elsewhere. */
5973 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
5975 /* look for the corresponding scalarizer dimension: dim. */
5976 for (dim = 0; dim < ndim; dim++)
5977 if (info->dim[dim] == n)
5980 /* loop exited early: the DIM being looked for has been found. */
5981 gcc_assert (dim < ndim);
5983 /* Set the new lower bound. */
5984 from = loop.from[dim];
5987 /* If we have an array section or are assigning make sure that
5988 the lower bound is 1. References to the full
5989 array should otherwise keep the original bounds. */
5991 || info->ref->u.ar.type != AR_FULL)
5992 && !integer_onep (from))
5994 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5995 gfc_array_index_type, gfc_index_one_node,
5997 to = fold_build2_loc (input_location, PLUS_EXPR,
5998 gfc_array_index_type, to, tmp);
5999 from = gfc_index_one_node;
6001 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6002 gfc_rank_cst[dim], from);
6004 /* Set the new upper bound. */
6005 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6006 gfc_rank_cst[dim], to);
6008 /* Multiply the stride by the section stride to get the
6010 stride = fold_build2_loc (input_location, MULT_EXPR,
6011 gfc_array_index_type,
6012 stride, info->stride[n]);
6014 if (se->direct_byref
6016 && info->ref->u.ar.type != AR_FULL)
6018 base = fold_build2_loc (input_location, MINUS_EXPR,
6019 TREE_TYPE (base), base, stride);
6021 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6023 tmp = gfc_conv_array_lbound (desc, n);
6024 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6025 TREE_TYPE (base), tmp, loop.from[dim]);
6026 tmp = fold_build2_loc (input_location, MULT_EXPR,
6027 TREE_TYPE (base), tmp,
6028 gfc_conv_array_stride (desc, n));
6029 base = fold_build2_loc (input_location, PLUS_EXPR,
6030 TREE_TYPE (base), tmp, base);
6033 /* Store the new stride. */
6034 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6035 gfc_rank_cst[dim], stride);
6038 for (n = ndim; n < ndim + codim; n++)
6040 /* look for the corresponding scalarizer dimension: dim. */
6041 for (dim = 0; dim < ndim + codim; dim++)
6042 if (info->dim[dim] == n)
6045 /* loop exited early: the DIM being looked for has been found. */
6046 gcc_assert (dim < ndim + codim);
6048 from = loop.from[dim];
6050 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6051 gfc_rank_cst[dim], from);
6052 if (n < ndim + codim - 1)
6053 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6054 gfc_rank_cst[dim], to);
6058 if (se->data_not_needed)
6059 gfc_conv_descriptor_data_set (&loop.pre, parm,
6060 gfc_index_zero_node);
6062 /* Point the data pointer at the 1st element in the section. */
6063 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6064 subref_array_target, expr);
6066 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6067 && !se->data_not_needed)
6069 /* Set the offset. */
6070 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6074 /* Only the callee knows what the correct offset it, so just set
6076 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6081 if (!se->direct_byref || se->byref_noassign)
6083 /* Get a pointer to the new descriptor. */
6084 if (se->want_pointer)
6085 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6090 gfc_add_block_to_block (&se->pre, &loop.pre);
6091 gfc_add_block_to_block (&se->post, &loop.post);
6093 /* Cleanup the scalarizer. */
6094 gfc_cleanup_loop (&loop);
6097 /* Helper function for gfc_conv_array_parameter if array size needs to be
6101 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6104 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6105 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6106 else if (expr->rank > 1)
6107 *size = build_call_expr_loc (input_location,
6108 gfor_fndecl_size0, 1,
6109 gfc_build_addr_expr (NULL, desc));
6112 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6113 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6115 *size = fold_build2_loc (input_location, MINUS_EXPR,
6116 gfc_array_index_type, ubound, lbound);
6117 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6118 *size, gfc_index_one_node);
6119 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6120 *size, gfc_index_zero_node);
6122 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6123 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6124 *size, fold_convert (gfc_array_index_type, elem));
6127 /* Convert an array for passing as an actual parameter. */
6128 /* TODO: Optimize passing g77 arrays. */
6131 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6132 const gfc_symbol *fsym, const char *proc_name,
6137 tree tmp = NULL_TREE;
6139 tree parent = DECL_CONTEXT (current_function_decl);
6140 bool full_array_var;
6141 bool this_array_result;
6144 bool array_constructor;
6145 bool good_allocatable;
6146 bool ultimate_ptr_comp;
6147 bool ultimate_alloc_comp;
6152 ultimate_ptr_comp = false;
6153 ultimate_alloc_comp = false;
6155 for (ref = expr->ref; ref; ref = ref->next)
6157 if (ref->next == NULL)
6160 if (ref->type == REF_COMPONENT)
6162 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6163 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6167 full_array_var = false;
6170 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6171 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6173 sym = full_array_var ? expr->symtree->n.sym : NULL;
6175 /* The symbol should have an array specification. */
6176 gcc_assert (!sym || sym->as || ref->u.ar.as);
6178 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6180 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6181 expr->ts.u.cl->backend_decl = tmp;
6182 se->string_length = tmp;
6185 /* Is this the result of the enclosing procedure? */
6186 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6187 if (this_array_result
6188 && (sym->backend_decl != current_function_decl)
6189 && (sym->backend_decl != parent))
6190 this_array_result = false;
6192 /* Passing address of the array if it is not pointer or assumed-shape. */
6193 if (full_array_var && g77 && !this_array_result)
6195 tmp = gfc_get_symbol_decl (sym);
6197 if (sym->ts.type == BT_CHARACTER)
6198 se->string_length = sym->ts.u.cl->backend_decl;
6200 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6202 gfc_conv_expr_descriptor (se, expr, ss);
6203 se->expr = gfc_conv_array_data (se->expr);
6207 if (!sym->attr.pointer
6209 && sym->as->type != AS_ASSUMED_SHAPE
6210 && !sym->attr.allocatable)
6212 /* Some variables are declared directly, others are declared as
6213 pointers and allocated on the heap. */
6214 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6217 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6219 array_parameter_size (tmp, expr, size);
6223 if (sym->attr.allocatable)
6225 if (sym->attr.dummy || sym->attr.result)
6227 gfc_conv_expr_descriptor (se, expr, ss);
6231 array_parameter_size (tmp, expr, size);
6232 se->expr = gfc_conv_array_data (tmp);
6237 /* A convenient reduction in scope. */
6238 contiguous = g77 && !this_array_result && contiguous;
6240 /* There is no need to pack and unpack the array, if it is contiguous
6241 and not a deferred- or assumed-shape array, or if it is simply
6243 no_pack = ((sym && sym->as
6244 && !sym->attr.pointer
6245 && sym->as->type != AS_DEFERRED
6246 && sym->as->type != AS_ASSUMED_SHAPE)
6248 (ref && ref->u.ar.as
6249 && ref->u.ar.as->type != AS_DEFERRED
6250 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6252 gfc_is_simply_contiguous (expr, false));
6254 no_pack = contiguous && no_pack;
6256 /* Array constructors are always contiguous and do not need packing. */
6257 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6259 /* Same is true of contiguous sections from allocatable variables. */
6260 good_allocatable = contiguous
6262 && expr->symtree->n.sym->attr.allocatable;
6264 /* Or ultimate allocatable components. */
6265 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6267 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6269 gfc_conv_expr_descriptor (se, expr, ss);
6270 if (expr->ts.type == BT_CHARACTER)
6271 se->string_length = expr->ts.u.cl->backend_decl;
6273 array_parameter_size (se->expr, expr, size);
6274 se->expr = gfc_conv_array_data (se->expr);
6278 if (this_array_result)
6280 /* Result of the enclosing function. */
6281 gfc_conv_expr_descriptor (se, expr, ss);
6283 array_parameter_size (se->expr, expr, size);
6284 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6286 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6287 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6288 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6295 /* Every other type of array. */
6296 se->want_pointer = 1;
6297 gfc_conv_expr_descriptor (se, expr, ss);
6299 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6304 /* Deallocate the allocatable components of structures that are
6306 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6307 && expr->ts.u.derived->attr.alloc_comp
6308 && expr->expr_type != EXPR_VARIABLE)
6310 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6311 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6313 /* The components shall be deallocated before their containing entity. */
6314 gfc_prepend_expr_to_block (&se->post, tmp);
6317 if (g77 || (fsym && fsym->attr.contiguous
6318 && !gfc_is_simply_contiguous (expr, false)))
6320 tree origptr = NULL_TREE;
6324 /* For contiguous arrays, save the original value of the descriptor. */
6327 origptr = gfc_create_var (pvoid_type_node, "origptr");
6328 tmp = build_fold_indirect_ref_loc (input_location, desc);
6329 tmp = gfc_conv_array_data (tmp);
6330 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6331 TREE_TYPE (origptr), origptr,
6332 fold_convert (TREE_TYPE (origptr), tmp));
6333 gfc_add_expr_to_block (&se->pre, tmp);
6336 /* Repack the array. */
6337 if (gfc_option.warn_array_temp)
6340 gfc_warning ("Creating array temporary at %L for argument '%s'",
6341 &expr->where, fsym->name);
6343 gfc_warning ("Creating array temporary at %L", &expr->where);
6346 ptr = build_call_expr_loc (input_location,
6347 gfor_fndecl_in_pack, 1, desc);
6349 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6351 tmp = gfc_conv_expr_present (sym);
6352 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6353 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6354 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6357 ptr = gfc_evaluate_now (ptr, &se->pre);
6359 /* Use the packed data for the actual argument, except for contiguous arrays,
6360 where the descriptor's data component is set. */
6365 tmp = build_fold_indirect_ref_loc (input_location, desc);
6366 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6369 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6373 if (fsym && proc_name)
6374 asprintf (&msg, "An array temporary was created for argument "
6375 "'%s' of procedure '%s'", fsym->name, proc_name);
6377 asprintf (&msg, "An array temporary was created");
6379 tmp = build_fold_indirect_ref_loc (input_location,
6381 tmp = gfc_conv_array_data (tmp);
6382 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6383 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6385 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6386 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6388 gfc_conv_expr_present (sym), tmp);
6390 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6395 gfc_start_block (&block);
6397 /* Copy the data back. */
6398 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6400 tmp = build_call_expr_loc (input_location,
6401 gfor_fndecl_in_unpack, 2, desc, ptr);
6402 gfc_add_expr_to_block (&block, tmp);
6405 /* Free the temporary. */
6406 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6407 gfc_add_expr_to_block (&block, tmp);
6409 stmt = gfc_finish_block (&block);
6411 gfc_init_block (&block);
6412 /* Only if it was repacked. This code needs to be executed before the
6413 loop cleanup code. */
6414 tmp = build_fold_indirect_ref_loc (input_location,
6416 tmp = gfc_conv_array_data (tmp);
6417 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6418 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6420 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6421 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6423 gfc_conv_expr_present (sym), tmp);
6425 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6427 gfc_add_expr_to_block (&block, tmp);
6428 gfc_add_block_to_block (&block, &se->post);
6430 gfc_init_block (&se->post);
6432 /* Reset the descriptor pointer. */
6435 tmp = build_fold_indirect_ref_loc (input_location, desc);
6436 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6439 gfc_add_block_to_block (&se->post, &block);
6444 /* Generate code to deallocate an array, if it is allocated. */
6447 gfc_trans_dealloc_allocated (tree descriptor)
6453 gfc_start_block (&block);
6455 var = gfc_conv_descriptor_data_get (descriptor);
6458 /* Call array_deallocate with an int * present in the second argument.
6459 Although it is ignored here, it's presence ensures that arrays that
6460 are already deallocated are ignored. */
6461 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6462 gfc_add_expr_to_block (&block, tmp);
6464 /* Zero the data pointer. */
6465 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6466 var, build_int_cst (TREE_TYPE (var), 0));
6467 gfc_add_expr_to_block (&block, tmp);
6469 return gfc_finish_block (&block);
6473 /* This helper function calculates the size in words of a full array. */
6476 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6481 idx = gfc_rank_cst[rank - 1];
6482 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6483 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6484 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6486 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6487 tmp, gfc_index_one_node);
6488 tmp = gfc_evaluate_now (tmp, block);
6490 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6491 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6493 return gfc_evaluate_now (tmp, block);
6497 /* Allocate dest to the same size as src, and copy src -> dest.
6498 If no_malloc is set, only the copy is done. */
6501 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6511 /* If the source is null, set the destination to null. Then,
6512 allocate memory to the destination. */
6513 gfc_init_block (&block);
6517 tmp = null_pointer_node;
6518 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6519 gfc_add_expr_to_block (&block, tmp);
6520 null_data = gfc_finish_block (&block);
6522 gfc_init_block (&block);
6523 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6526 tmp = gfc_call_malloc (&block, type, size);
6527 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6528 dest, fold_convert (type, tmp));
6529 gfc_add_expr_to_block (&block, tmp);
6532 tmp = built_in_decls[BUILT_IN_MEMCPY];
6533 tmp = build_call_expr_loc (input_location, tmp, 3,
6538 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6539 null_data = gfc_finish_block (&block);
6541 gfc_init_block (&block);
6542 nelems = get_full_array_size (&block, src, rank);
6543 tmp = fold_convert (gfc_array_index_type,
6544 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6545 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6549 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6550 tmp = gfc_call_malloc (&block, tmp, size);
6551 gfc_conv_descriptor_data_set (&block, dest, tmp);
6554 /* We know the temporary and the value will be the same length,
6555 so can use memcpy. */
6556 tmp = built_in_decls[BUILT_IN_MEMCPY];
6557 tmp = build_call_expr_loc (input_location,
6558 tmp, 3, gfc_conv_descriptor_data_get (dest),
6559 gfc_conv_descriptor_data_get (src), size);
6562 gfc_add_expr_to_block (&block, tmp);
6563 tmp = gfc_finish_block (&block);
6565 /* Null the destination if the source is null; otherwise do
6566 the allocate and copy. */
6570 null_cond = gfc_conv_descriptor_data_get (src);
6572 null_cond = convert (pvoid_type_node, null_cond);
6573 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6574 null_cond, null_pointer_node);
6575 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6579 /* Allocate dest to the same size as src, and copy data src -> dest. */
6582 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6584 return duplicate_allocatable (dest, src, type, rank, false);
6588 /* Copy data src -> dest. */
6591 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6593 return duplicate_allocatable (dest, src, type, rank, true);
6597 /* Recursively traverse an object of derived type, generating code to
6598 deallocate, nullify or copy allocatable components. This is the work horse
6599 function for the functions named in this enum. */
6601 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6602 COPY_ONLY_ALLOC_COMP};
6605 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6606 tree dest, int rank, int purpose)
6610 stmtblock_t fnblock;
6611 stmtblock_t loopbody;
6622 tree null_cond = NULL_TREE;
6624 gfc_init_block (&fnblock);
6626 decl_type = TREE_TYPE (decl);
6628 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6629 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6631 decl = build_fold_indirect_ref_loc (input_location,
6634 /* Just in case in gets dereferenced. */
6635 decl_type = TREE_TYPE (decl);
6637 /* If this an array of derived types with allocatable components
6638 build a loop and recursively call this function. */
6639 if (TREE_CODE (decl_type) == ARRAY_TYPE
6640 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6642 tmp = gfc_conv_array_data (decl);
6643 var = build_fold_indirect_ref_loc (input_location,
6646 /* Get the number of elements - 1 and set the counter. */
6647 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6649 /* Use the descriptor for an allocatable array. Since this
6650 is a full array reference, we only need the descriptor
6651 information from dimension = rank. */
6652 tmp = get_full_array_size (&fnblock, decl, rank);
6653 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6654 gfc_array_index_type, tmp,
6655 gfc_index_one_node);
6657 null_cond = gfc_conv_descriptor_data_get (decl);
6658 null_cond = fold_build2_loc (input_location, NE_EXPR,
6659 boolean_type_node, null_cond,
6660 build_int_cst (TREE_TYPE (null_cond), 0));
6664 /* Otherwise use the TYPE_DOMAIN information. */
6665 tmp = array_type_nelts (decl_type);
6666 tmp = fold_convert (gfc_array_index_type, tmp);
6669 /* Remember that this is, in fact, the no. of elements - 1. */
6670 nelems = gfc_evaluate_now (tmp, &fnblock);
6671 index = gfc_create_var (gfc_array_index_type, "S");
6673 /* Build the body of the loop. */
6674 gfc_init_block (&loopbody);
6676 vref = gfc_build_array_ref (var, index, NULL);
6678 if (purpose == COPY_ALLOC_COMP)
6680 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6682 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6683 gfc_add_expr_to_block (&fnblock, tmp);
6685 tmp = build_fold_indirect_ref_loc (input_location,
6686 gfc_conv_array_data (dest));
6687 dref = gfc_build_array_ref (tmp, index, NULL);
6688 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6690 else if (purpose == COPY_ONLY_ALLOC_COMP)
6692 tmp = build_fold_indirect_ref_loc (input_location,
6693 gfc_conv_array_data (dest));
6694 dref = gfc_build_array_ref (tmp, index, NULL);
6695 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6699 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6701 gfc_add_expr_to_block (&loopbody, tmp);
6703 /* Build the loop and return. */
6704 gfc_init_loopinfo (&loop);
6706 loop.from[0] = gfc_index_zero_node;
6707 loop.loopvar[0] = index;
6708 loop.to[0] = nelems;
6709 gfc_trans_scalarizing_loops (&loop, &loopbody);
6710 gfc_add_block_to_block (&fnblock, &loop.pre);
6712 tmp = gfc_finish_block (&fnblock);
6713 if (null_cond != NULL_TREE)
6714 tmp = build3_v (COND_EXPR, null_cond, tmp,
6715 build_empty_stmt (input_location));
6720 /* Otherwise, act on the components or recursively call self to
6721 act on a chain of components. */
6722 for (c = der_type->components; c; c = c->next)
6724 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6725 || c->ts.type == BT_CLASS)
6726 && c->ts.u.derived->attr.alloc_comp;
6727 cdecl = c->backend_decl;
6728 ctype = TREE_TYPE (cdecl);
6732 case DEALLOCATE_ALLOC_COMP:
6733 if (cmp_has_alloc_comps && !c->attr.pointer)
6735 /* Do not deallocate the components of ultimate pointer
6737 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6738 decl, cdecl, NULL_TREE);
6739 rank = c->as ? c->as->rank : 0;
6740 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6742 gfc_add_expr_to_block (&fnblock, tmp);
6745 if (c->attr.allocatable && c->attr.dimension)
6747 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6748 decl, cdecl, NULL_TREE);
6749 tmp = gfc_trans_dealloc_allocated (comp);
6750 gfc_add_expr_to_block (&fnblock, tmp);
6752 else if (c->attr.allocatable)
6754 /* Allocatable scalar components. */
6755 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6756 decl, cdecl, NULL_TREE);
6758 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6760 gfc_add_expr_to_block (&fnblock, tmp);
6762 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6763 void_type_node, comp,
6764 build_int_cst (TREE_TYPE (comp), 0));
6765 gfc_add_expr_to_block (&fnblock, tmp);
6767 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6769 /* Allocatable scalar CLASS components. */
6770 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6771 decl, cdecl, NULL_TREE);
6773 /* Add reference to '_data' component. */
6774 tmp = CLASS_DATA (c)->backend_decl;
6775 comp = fold_build3_loc (input_location, COMPONENT_REF,
6776 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6778 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6779 CLASS_DATA (c)->ts);
6780 gfc_add_expr_to_block (&fnblock, tmp);
6782 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6783 void_type_node, comp,
6784 build_int_cst (TREE_TYPE (comp), 0));
6785 gfc_add_expr_to_block (&fnblock, tmp);
6789 case NULLIFY_ALLOC_COMP:
6790 if (c->attr.pointer)
6792 else if (c->attr.allocatable && c->attr.dimension)
6794 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6795 decl, cdecl, NULL_TREE);
6796 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6798 else if (c->attr.allocatable)
6800 /* Allocatable scalar components. */
6801 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6802 decl, cdecl, NULL_TREE);
6803 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6804 void_type_node, comp,
6805 build_int_cst (TREE_TYPE (comp), 0));
6806 gfc_add_expr_to_block (&fnblock, tmp);
6808 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6810 /* Allocatable scalar CLASS components. */
6811 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6812 decl, cdecl, NULL_TREE);
6813 /* Add reference to '_data' component. */
6814 tmp = CLASS_DATA (c)->backend_decl;
6815 comp = fold_build3_loc (input_location, COMPONENT_REF,
6816 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6817 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6818 void_type_node, comp,
6819 build_int_cst (TREE_TYPE (comp), 0));
6820 gfc_add_expr_to_block (&fnblock, tmp);
6822 else if (cmp_has_alloc_comps)
6824 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6825 decl, cdecl, NULL_TREE);
6826 rank = c->as ? c->as->rank : 0;
6827 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6829 gfc_add_expr_to_block (&fnblock, tmp);
6833 case COPY_ALLOC_COMP:
6834 if (c->attr.pointer)
6837 /* We need source and destination components. */
6838 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6840 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6842 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6844 if (c->attr.allocatable && !cmp_has_alloc_comps)
6846 rank = c->as ? c->as->rank : 0;
6847 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6848 gfc_add_expr_to_block (&fnblock, tmp);
6851 if (cmp_has_alloc_comps)
6853 rank = c->as ? c->as->rank : 0;
6854 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6855 gfc_add_modify (&fnblock, dcmp, tmp);
6856 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
6858 gfc_add_expr_to_block (&fnblock, tmp);
6868 return gfc_finish_block (&fnblock);
6871 /* Recursively traverse an object of derived type, generating code to
6872 nullify allocatable components. */
6875 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6877 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6878 NULLIFY_ALLOC_COMP);
6882 /* Recursively traverse an object of derived type, generating code to
6883 deallocate allocatable components. */
6886 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
6888 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
6889 DEALLOCATE_ALLOC_COMP);
6893 /* Recursively traverse an object of derived type, generating code to
6894 copy it and its allocatable components. */
6897 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6899 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
6903 /* Recursively traverse an object of derived type, generating code to
6904 copy only its allocatable components. */
6907 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
6909 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
6913 /* Returns the value of LBOUND for an expression. This could be broken out
6914 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
6915 called by gfc_alloc_allocatable_for_assignment. */
6917 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
6922 tree cond, cond1, cond3, cond4;
6926 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6928 tmp = gfc_rank_cst[dim];
6929 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
6930 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
6931 stride = gfc_conv_descriptor_stride_get (desc, tmp);
6932 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6934 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6935 stride, gfc_index_zero_node);
6936 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6937 boolean_type_node, cond3, cond1);
6938 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6939 stride, gfc_index_zero_node);
6941 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6942 tmp, build_int_cst (gfc_array_index_type,
6945 cond = boolean_false_node;
6947 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6948 boolean_type_node, cond3, cond4);
6949 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6950 boolean_type_node, cond, cond1);
6952 return fold_build3_loc (input_location, COND_EXPR,
6953 gfc_array_index_type, cond,
6954 lbound, gfc_index_one_node);
6956 else if (expr->expr_type == EXPR_VARIABLE)
6958 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6959 for (ref = expr->ref; ref; ref = ref->next)
6961 if (ref->type == REF_COMPONENT
6962 && ref->u.c.component->as
6964 && ref->next->u.ar.type == AR_FULL)
6965 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
6967 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
6969 else if (expr->expr_type == EXPR_FUNCTION)
6971 /* A conversion function, so use the argument. */
6972 expr = expr->value.function.actual->expr;
6973 if (expr->expr_type != EXPR_VARIABLE)
6974 return gfc_index_one_node;
6975 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
6976 return get_std_lbound (expr, desc, dim, assumed_size);
6979 return gfc_index_one_node;
6983 /* Returns true if an expression represents an lhs that can be reallocated
6987 gfc_is_reallocatable_lhs (gfc_expr *expr)
6994 /* An allocatable variable. */
6995 if (expr->symtree->n.sym->attr.allocatable
6997 && expr->ref->type == REF_ARRAY
6998 && expr->ref->u.ar.type == AR_FULL)
7001 /* All that can be left are allocatable components. */
7002 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7003 && expr->symtree->n.sym->ts.type != BT_CLASS)
7004 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7007 /* Find a component ref followed by an array reference. */
7008 for (ref = expr->ref; ref; ref = ref->next)
7010 && ref->type == REF_COMPONENT
7011 && ref->next->type == REF_ARRAY
7012 && !ref->next->next)
7018 /* Return true if valid reallocatable lhs. */
7019 if (ref->u.c.component->attr.allocatable
7020 && ref->next->u.ar.type == AR_FULL)
7027 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7031 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7035 stmtblock_t realloc_block;
7036 stmtblock_t alloc_block;
7059 gfc_array_spec * as;
7061 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7062 Find the lhs expression in the loop chain and set expr1 and
7063 expr2 accordingly. */
7064 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7067 /* Find the ss for the lhs. */
7069 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7070 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7072 if (lss == gfc_ss_terminator)
7077 /* Bail out if this is not a valid allocate on assignment. */
7078 if (!gfc_is_reallocatable_lhs (expr1)
7079 || (expr2 && !expr2->rank))
7082 /* Find the ss for the lhs. */
7084 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7085 if (lss->expr == expr1)
7088 if (lss == gfc_ss_terminator)
7091 /* Find an ss for the rhs. For operator expressions, we see the
7092 ss's for the operands. Any one of these will do. */
7094 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7095 if (rss->expr != expr1 && rss != loop->temp_ss)
7098 if (expr2 && rss == gfc_ss_terminator)
7101 gfc_start_block (&fblock);
7103 /* Since the lhs is allocatable, this must be a descriptor type.
7104 Get the data and array size. */
7105 desc = lss->data.info.descriptor;
7106 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7107 array1 = gfc_conv_descriptor_data_get (desc);
7109 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7110 deallocated if expr is an array of different shape or any of the
7111 corresponding length type parameter values of variable and expr
7112 differ." This assures F95 compatibility. */
7113 jump_label1 = gfc_build_label_decl (NULL_TREE);
7114 jump_label2 = gfc_build_label_decl (NULL_TREE);
7116 /* Allocate if data is NULL. */
7117 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7118 array1, build_int_cst (TREE_TYPE (array1), 0));
7119 tmp = build3_v (COND_EXPR, cond,
7120 build1_v (GOTO_EXPR, jump_label1),
7121 build_empty_stmt (input_location));
7122 gfc_add_expr_to_block (&fblock, tmp);
7124 /* Get arrayspec if expr is a full array. */
7125 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7126 && expr2->value.function.isym
7127 && expr2->value.function.isym->conversion)
7129 /* For conversion functions, take the arg. */
7130 gfc_expr *arg = expr2->value.function.actual->expr;
7131 as = gfc_get_full_arrayspec_from_expr (arg);
7134 as = gfc_get_full_arrayspec_from_expr (expr2);
7138 /* If the lhs shape is not the same as the rhs jump to setting the
7139 bounds and doing the reallocation....... */
7140 for (n = 0; n < expr1->rank; n++)
7142 /* Check the shape. */
7143 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7144 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7145 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7146 gfc_array_index_type,
7147 loop->to[n], loop->from[n]);
7148 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7149 gfc_array_index_type,
7151 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7152 gfc_array_index_type,
7154 cond = fold_build2_loc (input_location, NE_EXPR,
7156 tmp, gfc_index_zero_node);
7157 tmp = build3_v (COND_EXPR, cond,
7158 build1_v (GOTO_EXPR, jump_label1),
7159 build_empty_stmt (input_location));
7160 gfc_add_expr_to_block (&fblock, tmp);
7163 /* ....else jump past the (re)alloc code. */
7164 tmp = build1_v (GOTO_EXPR, jump_label2);
7165 gfc_add_expr_to_block (&fblock, tmp);
7167 /* Add the label to start automatic (re)allocation. */
7168 tmp = build1_v (LABEL_EXPR, jump_label1);
7169 gfc_add_expr_to_block (&fblock, tmp);
7171 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7173 /* Get the rhs size. Fix both sizes. */
7175 desc2 = rss->data.info.descriptor;
7178 size2 = gfc_index_one_node;
7179 for (n = 0; n < expr2->rank; n++)
7181 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7182 gfc_array_index_type,
7183 loop->to[n], loop->from[n]);
7184 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7185 gfc_array_index_type,
7186 tmp, gfc_index_one_node);
7187 size2 = fold_build2_loc (input_location, MULT_EXPR,
7188 gfc_array_index_type,
7192 size1 = gfc_evaluate_now (size1, &fblock);
7193 size2 = gfc_evaluate_now (size2, &fblock);
7195 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7197 neq_size = gfc_evaluate_now (cond, &fblock);
7200 /* Now modify the lhs descriptor and the associated scalarizer
7201 variables. F2003 7.4.1.3: "If variable is or becomes an
7202 unallocated allocatable variable, then it is allocated with each
7203 deferred type parameter equal to the corresponding type parameters
7204 of expr , with the shape of expr , and with each lower bound equal
7205 to the corresponding element of LBOUND(expr)."
7206 Reuse size1 to keep a dimension-by-dimension track of the
7207 stride of the new array. */
7208 size1 = gfc_index_one_node;
7209 offset = gfc_index_zero_node;
7211 for (n = 0; n < expr2->rank; n++)
7213 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7214 gfc_array_index_type,
7215 loop->to[n], loop->from[n]);
7216 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7217 gfc_array_index_type,
7218 tmp, gfc_index_one_node);
7220 lbound = gfc_index_one_node;
7225 lbd = get_std_lbound (expr2, desc2, n,
7226 as->type == AS_ASSUMED_SIZE);
7227 ubound = fold_build2_loc (input_location,
7229 gfc_array_index_type,
7231 ubound = fold_build2_loc (input_location,
7233 gfc_array_index_type,
7238 gfc_conv_descriptor_lbound_set (&fblock, desc,
7241 gfc_conv_descriptor_ubound_set (&fblock, desc,
7244 gfc_conv_descriptor_stride_set (&fblock, desc,
7247 lbound = gfc_conv_descriptor_lbound_get (desc,
7249 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7250 gfc_array_index_type,
7252 offset = fold_build2_loc (input_location, MINUS_EXPR,
7253 gfc_array_index_type,
7255 size1 = fold_build2_loc (input_location, MULT_EXPR,
7256 gfc_array_index_type,
7260 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7261 the array offset is saved and the info.offset is used for a
7262 running offset. Use the saved_offset instead. */
7263 tmp = gfc_conv_descriptor_offset (desc);
7264 gfc_add_modify (&fblock, tmp, offset);
7265 if (lss->data.info.saved_offset
7266 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7267 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7269 /* Now set the deltas for the lhs. */
7270 for (n = 0; n < expr1->rank; n++)
7272 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7273 dim = lss->data.info.dim[n];
7274 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7275 gfc_array_index_type, tmp,
7277 if (lss->data.info.delta[dim]
7278 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7279 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7282 /* Get the new lhs size in bytes. */
7283 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7285 tmp = expr2->ts.u.cl->backend_decl;
7286 gcc_assert (expr1->ts.u.cl->backend_decl);
7287 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7288 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7290 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7292 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7293 tmp = fold_build2_loc (input_location, MULT_EXPR,
7294 gfc_array_index_type, tmp,
7295 expr1->ts.u.cl->backend_decl);
7298 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7299 tmp = fold_convert (gfc_array_index_type, tmp);
7300 size2 = fold_build2_loc (input_location, MULT_EXPR,
7301 gfc_array_index_type,
7303 size2 = fold_convert (size_type_node, size2);
7304 size2 = gfc_evaluate_now (size2, &fblock);
7306 /* Realloc expression. Note that the scalarizer uses desc.data
7307 in the array reference - (*desc.data)[<element>]. */
7308 gfc_init_block (&realloc_block);
7309 tmp = build_call_expr_loc (input_location,
7310 built_in_decls[BUILT_IN_REALLOC], 2,
7311 fold_convert (pvoid_type_node, array1),
7313 gfc_conv_descriptor_data_set (&realloc_block,
7315 realloc_expr = gfc_finish_block (&realloc_block);
7317 /* Only reallocate if sizes are different. */
7318 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7319 build_empty_stmt (input_location));
7323 /* Malloc expression. */
7324 gfc_init_block (&alloc_block);
7325 tmp = build_call_expr_loc (input_location,
7326 built_in_decls[BUILT_IN_MALLOC], 1,
7328 gfc_conv_descriptor_data_set (&alloc_block,
7330 tmp = gfc_conv_descriptor_dtype (desc);
7331 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7332 alloc_expr = gfc_finish_block (&alloc_block);
7334 /* Malloc if not allocated; realloc otherwise. */
7335 tmp = build_int_cst (TREE_TYPE (array1), 0);
7336 cond = fold_build2_loc (input_location, EQ_EXPR,
7339 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7340 gfc_add_expr_to_block (&fblock, tmp);
7342 /* Make sure that the scalarizer data pointer is updated. */
7343 if (lss->data.info.data
7344 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7346 tmp = gfc_conv_descriptor_data_get (desc);
7347 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7350 /* Add the exit label. */
7351 tmp = build1_v (LABEL_EXPR, jump_label2);
7352 gfc_add_expr_to_block (&fblock, tmp);
7354 return gfc_finish_block (&fblock);
7358 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7359 Do likewise, recursively if necessary, with the allocatable components of
7363 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7369 stmtblock_t cleanup;
7372 bool sym_has_alloc_comp;
7374 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7375 || sym->ts.type == BT_CLASS)
7376 && sym->ts.u.derived->attr.alloc_comp;
7378 /* Make sure the frontend gets these right. */
7379 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7380 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7381 "allocatable attribute or derived type without allocatable "
7384 gfc_save_backend_locus (&loc);
7385 gfc_set_backend_locus (&sym->declared_at);
7386 gfc_init_block (&init);
7388 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7389 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7391 if (sym->ts.type == BT_CHARACTER
7392 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7394 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7395 gfc_trans_vla_type_sizes (sym, &init);
7398 /* Dummy, use associated and result variables don't need anything special. */
7399 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7401 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7402 gfc_restore_backend_locus (&loc);
7406 descriptor = sym->backend_decl;
7408 /* Although static, derived types with default initializers and
7409 allocatable components must not be nulled wholesale; instead they
7410 are treated component by component. */
7411 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7413 /* SAVEd variables are not freed on exit. */
7414 gfc_trans_static_array_pointer (sym);
7416 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7417 gfc_restore_backend_locus (&loc);
7421 /* Get the descriptor type. */
7422 type = TREE_TYPE (sym->backend_decl);
7424 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7427 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7429 if (sym->value == NULL
7430 || !gfc_has_default_initializer (sym->ts.u.derived))
7432 rank = sym->as ? sym->as->rank : 0;
7433 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7435 gfc_add_expr_to_block (&init, tmp);
7438 gfc_init_default_dt (sym, &init, false);
7441 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7443 /* If the backend_decl is not a descriptor, we must have a pointer
7445 descriptor = build_fold_indirect_ref_loc (input_location,
7447 type = TREE_TYPE (descriptor);
7450 /* NULLIFY the data pointer. */
7451 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7452 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7454 gfc_restore_backend_locus (&loc);
7455 gfc_init_block (&cleanup);
7457 /* Allocatable arrays need to be freed when they go out of scope.
7458 The allocatable components of pointers must not be touched. */
7459 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7460 && !sym->attr.pointer && !sym->attr.save)
7463 rank = sym->as ? sym->as->rank : 0;
7464 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7465 gfc_add_expr_to_block (&cleanup, tmp);
7468 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7469 && !sym->attr.save && !sym->attr.result)
7471 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7472 gfc_add_expr_to_block (&cleanup, tmp);
7475 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7476 gfc_finish_block (&cleanup));
7479 /************ Expression Walking Functions ******************/
7481 /* Walk a variable reference.
7483 Possible extension - multiple component subscripts.
7484 x(:,:) = foo%a(:)%b(:)
7486 forall (i=..., j=...)
7487 x(i,j) = foo%a(j)%b(i)
7489 This adds a fair amount of complexity because you need to deal with more
7490 than one ref. Maybe handle in a similar manner to vector subscripts.
7491 Maybe not worth the effort. */
7495 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7502 for (ref = expr->ref; ref; ref = ref->next)
7503 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7506 for (; ref; ref = ref->next)
7508 if (ref->type == REF_SUBSTRING)
7510 newss = gfc_get_ss ();
7511 newss->type = GFC_SS_SCALAR;
7512 newss->expr = ref->u.ss.start;
7516 newss = gfc_get_ss ();
7517 newss->type = GFC_SS_SCALAR;
7518 newss->expr = ref->u.ss.end;
7523 /* We're only interested in array sections from now on. */
7524 if (ref->type != REF_ARRAY)
7529 if (ar->as->rank == 0 && ref->next != NULL)
7531 /* Scalar coarray. */
7538 for (n = 0; n < ar->dimen + ar->codimen; n++)
7540 newss = gfc_get_ss ();
7541 newss->type = GFC_SS_SCALAR;
7542 newss->expr = ar->start[n];
7549 newss = gfc_get_ss ();
7550 newss->type = GFC_SS_SECTION;
7553 newss->data.info.dimen = ar->as->rank;
7554 newss->data.info.codimen = 0;
7555 newss->data.info.ref = ref;
7557 /* Make sure array is the same as array(:,:), this way
7558 we don't need to special case all the time. */
7559 ar->dimen = ar->as->rank;
7561 for (n = 0; n < ar->dimen; n++)
7563 newss->data.info.dim[n] = n;
7564 ar->dimen_type[n] = DIMEN_RANGE;
7566 gcc_assert (ar->start[n] == NULL);
7567 gcc_assert (ar->end[n] == NULL);
7568 gcc_assert (ar->stride[n] == NULL);
7570 for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
7572 newss->data.info.dim[n] = n;
7573 ar->dimen_type[n] = DIMEN_RANGE;
7575 gcc_assert (ar->start[n] == NULL);
7576 gcc_assert (ar->end[n] == NULL);
7582 newss = gfc_get_ss ();
7583 newss->type = GFC_SS_SECTION;
7586 newss->data.info.dimen = 0;
7587 newss->data.info.codimen = 0;
7588 newss->data.info.ref = ref;
7590 /* We add SS chains for all the subscripts in the section. */
7591 for (n = 0; n < ar->dimen + ar->codimen; n++)
7595 switch (ar->dimen_type[n])
7597 case DIMEN_THIS_IMAGE:
7600 /* Add SS for elemental (scalar) subscripts. */
7601 gcc_assert (ar->start[n]);
7602 indexss = gfc_get_ss ();
7603 indexss->type = GFC_SS_SCALAR;
7604 indexss->expr = ar->start[n];
7605 indexss->next = gfc_ss_terminator;
7606 indexss->loop_chain = gfc_ss_terminator;
7607 newss->data.info.subscript[n] = indexss;
7611 /* We don't add anything for sections, just remember this
7612 dimension for later. */
7613 newss->data.info.dim[newss->data.info.dimen
7614 + newss->data.info.codimen] = n;
7616 newss->data.info.dimen++;
7620 /* Create a GFC_SS_VECTOR index in which we can store
7621 the vector's descriptor. */
7622 indexss = gfc_get_ss ();
7623 indexss->type = GFC_SS_VECTOR;
7624 indexss->expr = ar->start[n];
7625 indexss->next = gfc_ss_terminator;
7626 indexss->loop_chain = gfc_ss_terminator;
7627 newss->data.info.subscript[n] = indexss;
7628 newss->data.info.dim[newss->data.info.dimen
7629 + newss->data.info.codimen] = n;
7631 newss->data.info.dimen++;
7635 /* We should know what sort of section it is by now. */
7639 /* We should have at least one non-elemental dimension. */
7640 gcc_assert (newss->data.info.dimen > 0);
7645 /* We should know what sort of section it is by now. */
7654 /* Walk an expression operator. If only one operand of a binary expression is
7655 scalar, we must also add the scalar term to the SS chain. */
7658 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7664 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7665 if (expr->value.op.op2 == NULL)
7668 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7670 /* All operands are scalar. Pass back and let the caller deal with it. */
7674 /* All operands require scalarization. */
7675 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7678 /* One of the operands needs scalarization, the other is scalar.
7679 Create a gfc_ss for the scalar expression. */
7680 newss = gfc_get_ss ();
7681 newss->type = GFC_SS_SCALAR;
7684 /* First operand is scalar. We build the chain in reverse order, so
7685 add the scalar SS after the second operand. */
7687 while (head && head->next != ss)
7689 /* Check we haven't somehow broken the chain. */
7693 newss->expr = expr->value.op.op1;
7695 else /* head2 == head */
7697 gcc_assert (head2 == head);
7698 /* Second operand is scalar. */
7699 newss->next = head2;
7701 newss->expr = expr->value.op.op2;
7708 /* Reverse a SS chain. */
7711 gfc_reverse_ss (gfc_ss * ss)
7716 gcc_assert (ss != NULL);
7718 head = gfc_ss_terminator;
7719 while (ss != gfc_ss_terminator)
7722 /* Check we didn't somehow break the chain. */
7723 gcc_assert (next != NULL);
7733 /* Walk the arguments of an elemental function. */
7736 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7744 head = gfc_ss_terminator;
7747 for (; arg; arg = arg->next)
7752 newss = gfc_walk_subexpr (head, arg->expr);
7755 /* Scalar argument. */
7756 newss = gfc_get_ss ();
7758 newss->expr = arg->expr;
7768 while (tail->next != gfc_ss_terminator)
7775 /* If all the arguments are scalar we don't need the argument SS. */
7776 gfc_free_ss_chain (head);
7781 /* Add it onto the existing chain. */
7787 /* Walk a function call. Scalar functions are passed back, and taken out of
7788 scalarization loops. For elemental functions we walk their arguments.
7789 The result of functions returning arrays is stored in a temporary outside
7790 the loop, so that the function is only called once. Hence we do not need
7791 to walk their arguments. */
7794 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7797 gfc_intrinsic_sym *isym;
7799 gfc_component *comp = NULL;
7802 isym = expr->value.function.isym;
7804 /* Handle intrinsic functions separately. */
7806 return gfc_walk_intrinsic_function (ss, expr, isym);
7808 sym = expr->value.function.esym;
7810 sym = expr->symtree->n.sym;
7812 /* A function that returns arrays. */
7813 gfc_is_proc_ptr_comp (expr, &comp);
7814 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7815 || (comp && comp->attr.dimension))
7817 newss = gfc_get_ss ();
7818 newss->type = GFC_SS_FUNCTION;
7821 newss->data.info.dimen = expr->rank;
7822 for (n = 0; n < newss->data.info.dimen; n++)
7823 newss->data.info.dim[n] = n;
7827 /* Walk the parameters of an elemental function. For now we always pass
7829 if (sym->attr.elemental)
7830 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7833 /* Scalar functions are OK as these are evaluated outside the scalarization
7834 loop. Pass back and let the caller deal with it. */
7839 /* An array temporary is constructed for array constructors. */
7842 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7847 newss = gfc_get_ss ();
7848 newss->type = GFC_SS_CONSTRUCTOR;
7851 newss->data.info.dimen = expr->rank;
7852 for (n = 0; n < expr->rank; n++)
7853 newss->data.info.dim[n] = n;
7859 /* Walk an expression. Add walked expressions to the head of the SS chain.
7860 A wholly scalar expression will not be added. */
7863 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7867 switch (expr->expr_type)
7870 head = gfc_walk_variable_expr (ss, expr);
7874 head = gfc_walk_op_expr (ss, expr);
7878 head = gfc_walk_function_expr (ss, expr);
7883 case EXPR_STRUCTURE:
7884 /* Pass back and let the caller deal with it. */
7888 head = gfc_walk_array_constructor (ss, expr);
7891 case EXPR_SUBSTRING:
7892 /* Pass back and let the caller deal with it. */
7896 internal_error ("bad expression type during walk (%d)",
7903 /* Entry point for expression walking.
7904 A return value equal to the passed chain means this is
7905 a scalar expression. It is up to the caller to take whatever action is
7906 necessary to translate these. */
7909 gfc_walk_expr (gfc_expr * expr)
7913 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7914 return gfc_reverse_ss (res);