1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-array.c-- Various array related code, including scalarization,
25 allocation, initialization and other support routines. */
27 /* How the scalarizer works.
28 In gfortran, array expressions use the same core routines as scalar
30 First, a Scalarization State (SS) chain is built. This is done by walking
31 the expression tree, and building a linear list of the terms in the
32 expression. As the tree is walked, scalar subexpressions are translated.
34 The scalarization parameters are stored in a gfc_loopinfo structure.
35 First the start and stride of each term is calculated by
36 gfc_conv_ss_startstride. During this process the expressions for the array
37 descriptors and data pointers are also translated.
39 If the expression is an assignment, we must then resolve any dependencies.
40 In fortran all the rhs values of an assignment must be evaluated before
41 any assignments take place. This can require a temporary array to store the
42 values. We also require a temporary when we are passing array expressions
43 or vector subscripts as procedure parameters.
45 Array sections are passed without copying to a temporary. These use the
46 scalarizer to determine the shape of the section. The flag
47 loop->array_parameter tells the scalarizer that the actual values and loop
48 variables will not be required.
50 The function gfc_conv_loop_setup generates the scalarization setup code.
51 It determines the range of the scalarizing loop variables. If a temporary
52 is required, this is created and initialized. Code for scalar expressions
53 taken outside the loop is also generated at this time. Next the offset and
54 scaling required to translate from loop variables to array indices for each
57 A call to gfc_start_scalarized_body marks the start of the scalarized
58 expression. This creates a scope and declares the loop variables. Before
59 calling this gfc_make_ss_chain_used must be used to indicate which terms
60 will be used inside this loop.
62 The scalar gfc_conv_* functions are then used to build the main body of the
63 scalarization loop. Scalarization loop variables and precalculated scalar
64 values are automatically substituted. Note that gfc_advance_se_ss_chain
65 must be used, rather than changing the se->ss directly.
67 For assignment expressions requiring a temporary two sub loops are
68 generated. The first stores the result of the expression in the temporary,
69 the second copies it to the result. A call to
70 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
71 the start of the copying loop. The temporary may be less than full rank.
73 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
74 loops. The loops are added to the pre chain of the loopinfo. The post
75 chain may still contain cleanup code.
77 After the loop code has been added into its parent scope gfc_cleanup_loop
78 is called to free all the SS allocated by the scalarizer. */
82 #include "coretypes.h"
85 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
88 #include "constructor.h"
90 #include "trans-stmt.h"
91 #include "trans-types.h"
92 #include "trans-array.h"
93 #include "trans-const.h"
94 #include "dependency.h"
96 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
98 /* The contents of this structure aren't actually used, just the address. */
99 static gfc_ss gfc_ss_terminator_var;
100 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
104 gfc_array_dataptr_type (tree desc)
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
110 /* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
126 Don't forget to #undef these! */
129 #define OFFSET_FIELD 1
130 #define DTYPE_FIELD 2
131 #define DIMENSION_FIELD 3
132 #define CAF_TOKEN_FIELD 4
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
138 /* This provides READ-ONLY access to the data field. The field itself
139 doesn't have the proper type. */
142 gfc_conv_descriptor_data_get (tree desc)
146 type = TREE_TYPE (desc);
147 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149 field = TYPE_FIELDS (type);
150 gcc_assert (DATA_FIELD == 0);
152 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field.
161 TUPLES_P is true if we are generating tuples.
163 This function gets called through the following macros:
164 gfc_conv_descriptor_data_set
165 gfc_conv_descriptor_data_set. */
168 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
172 type = TREE_TYPE (desc);
173 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
175 field = TYPE_FIELDS (type);
176 gcc_assert (DATA_FIELD == 0);
178 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
180 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
184 /* This provides address access to the data field. This should only be
185 used by array allocation, passing this on to the runtime. */
188 gfc_conv_descriptor_data_addr (tree desc)
192 type = TREE_TYPE (desc);
193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
195 field = TYPE_FIELDS (type);
196 gcc_assert (DATA_FIELD == 0);
198 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
200 return gfc_build_addr_expr (NULL_TREE, t);
204 gfc_conv_descriptor_offset (tree desc)
209 type = TREE_TYPE (desc);
210 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
212 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
213 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
215 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
216 desc, field, NULL_TREE);
220 gfc_conv_descriptor_offset_get (tree desc)
222 return gfc_conv_descriptor_offset (desc);
226 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
229 tree t = gfc_conv_descriptor_offset (desc);
230 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
235 gfc_conv_descriptor_dtype (tree desc)
240 type = TREE_TYPE (desc);
241 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
243 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
244 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
246 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
247 desc, field, NULL_TREE);
251 gfc_conv_descriptor_dimension (tree desc, tree dim)
257 type = TREE_TYPE (desc);
258 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
260 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
261 gcc_assert (field != NULL_TREE
262 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
263 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
265 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
266 desc, field, NULL_TREE);
267 tmp = gfc_build_array_ref (tmp, dim, NULL);
273 gfc_conv_descriptor_token (tree desc)
278 type = TREE_TYPE (desc);
279 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
280 gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
281 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
282 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
283 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
285 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
286 desc, field, NULL_TREE);
291 gfc_conv_descriptor_stride (tree desc, tree dim)
296 tmp = gfc_conv_descriptor_dimension (desc, dim);
297 field = TYPE_FIELDS (TREE_TYPE (tmp));
298 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
299 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
301 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
302 tmp, field, NULL_TREE);
307 gfc_conv_descriptor_stride_get (tree desc, tree dim)
309 tree type = TREE_TYPE (desc);
310 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
311 if (integer_zerop (dim)
312 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
313 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
314 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
315 return gfc_index_one_node;
317 return gfc_conv_descriptor_stride (desc, dim);
321 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
322 tree dim, tree value)
324 tree t = gfc_conv_descriptor_stride (desc, dim);
325 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
329 gfc_conv_descriptor_lbound (tree desc, tree dim)
334 tmp = gfc_conv_descriptor_dimension (desc, dim);
335 field = TYPE_FIELDS (TREE_TYPE (tmp));
336 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
337 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
339 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
340 tmp, field, NULL_TREE);
345 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
347 return gfc_conv_descriptor_lbound (desc, dim);
351 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
352 tree dim, tree value)
354 tree t = gfc_conv_descriptor_lbound (desc, dim);
355 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
359 gfc_conv_descriptor_ubound (tree desc, tree dim)
364 tmp = gfc_conv_descriptor_dimension (desc, dim);
365 field = TYPE_FIELDS (TREE_TYPE (tmp));
366 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
367 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
369 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
370 tmp, field, NULL_TREE);
375 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
377 return gfc_conv_descriptor_ubound (desc, dim);
381 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
382 tree dim, tree value)
384 tree t = gfc_conv_descriptor_ubound (desc, dim);
385 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
388 /* Build a null array descriptor constructor. */
391 gfc_build_null_descriptor (tree type)
396 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
397 gcc_assert (DATA_FIELD == 0);
398 field = TYPE_FIELDS (type);
400 /* Set a NULL data pointer. */
401 tmp = build_constructor_single (type, field, null_pointer_node);
402 TREE_CONSTANT (tmp) = 1;
403 /* All other fields are ignored. */
409 /* Modify a descriptor such that the lbound of a given dimension is the value
410 specified. This also updates ubound and offset accordingly. */
413 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
414 int dim, tree new_lbound)
416 tree offs, ubound, lbound, stride;
417 tree diff, offs_diff;
419 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
421 offs = gfc_conv_descriptor_offset_get (desc);
422 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
423 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
424 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
426 /* Get difference (new - old) by which to shift stuff. */
427 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
430 /* Shift ubound and offset accordingly. This has to be done before
431 updating the lbound, as they depend on the lbound expression! */
432 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
434 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
435 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
437 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
439 gfc_conv_descriptor_offset_set (block, desc, offs);
441 /* Finally set lbound to value we want. */
442 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
446 /* Cleanup those #defines. */
451 #undef DIMENSION_FIELD
452 #undef CAF_TOKEN_FIELD
453 #undef STRIDE_SUBFIELD
454 #undef LBOUND_SUBFIELD
455 #undef UBOUND_SUBFIELD
458 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
459 flags & 1 = Main loop body.
460 flags & 2 = temp copy loop. */
463 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
465 for (; ss != gfc_ss_terminator; ss = ss->next)
466 ss->useflags = flags;
469 static void gfc_free_ss (gfc_ss *);
472 /* Free a gfc_ss chain. */
475 gfc_free_ss_chain (gfc_ss * ss)
479 while (ss != gfc_ss_terminator)
481 gcc_assert (ss != NULL);
490 free_ss_info (gfc_ss_info *ss_info)
499 gfc_free_ss (gfc_ss * ss)
501 gfc_ss_info *ss_info;
506 switch (ss_info->type)
509 for (n = 0; n < ss->dimen; n++)
511 if (ss->data.info.subscript[ss->dim[n]])
512 gfc_free_ss_chain (ss->data.info.subscript[ss->dim[n]]);
520 free_ss_info (ss_info);
525 /* Creates and initializes an array type gfc_ss struct. */
528 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
531 gfc_ss_info *ss_info;
534 ss_info = gfc_get_ss_info ();
535 ss_info->type = type;
542 for (i = 0; i < ss->dimen; i++)
549 /* Creates and initializes a temporary type gfc_ss struct. */
552 gfc_get_temp_ss (tree type, tree string_length, int dimen)
555 gfc_ss_info *ss_info;
558 ss_info = gfc_get_ss_info ();
559 ss_info->type = GFC_SS_TEMP;
563 ss->next = gfc_ss_terminator;
564 ss->string_length = string_length;
565 ss->data.temp.type = type;
567 for (i = 0; i < ss->dimen; i++)
574 /* Creates and initializes a scalar type gfc_ss struct. */
577 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
580 gfc_ss_info *ss_info;
582 ss_info = gfc_get_ss_info ();
583 ss_info->type = GFC_SS_SCALAR;
594 /* Free all the SS associated with a loop. */
597 gfc_cleanup_loop (gfc_loopinfo * loop)
603 while (ss != gfc_ss_terminator)
605 gcc_assert (ss != NULL);
606 next = ss->loop_chain;
613 /* Associate a SS chain with a loop. */
616 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
620 if (head == gfc_ss_terminator)
624 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
626 if (ss->next == gfc_ss_terminator)
627 ss->loop_chain = loop->ss;
629 ss->loop_chain = ss->next;
631 gcc_assert (ss == gfc_ss_terminator);
636 /* Generate an initializer for a static pointer or allocatable array. */
639 gfc_trans_static_array_pointer (gfc_symbol * sym)
643 gcc_assert (TREE_STATIC (sym->backend_decl));
644 /* Just zero the data member. */
645 type = TREE_TYPE (sym->backend_decl);
646 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
650 /* If the bounds of SE's loop have not yet been set, see if they can be
651 determined from array spec AS, which is the array spec of a called
652 function. MAPPING maps the callee's dummy arguments to the values
653 that the caller is passing. Add any initialization and finalization
657 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
658 gfc_se * se, gfc_array_spec * as)
666 if (as && as->type == AS_EXPLICIT)
667 for (n = 0; n < se->loop->dimen; n++)
669 dim = se->ss->dim[n];
670 gcc_assert (dim < as->rank);
671 gcc_assert (se->loop->dimen == as->rank);
672 if (se->loop->to[n] == NULL_TREE)
674 /* Evaluate the lower bound. */
675 gfc_init_se (&tmpse, NULL);
676 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
677 gfc_add_block_to_block (&se->pre, &tmpse.pre);
678 gfc_add_block_to_block (&se->post, &tmpse.post);
679 lower = fold_convert (gfc_array_index_type, tmpse.expr);
681 /* ...and the upper bound. */
682 gfc_init_se (&tmpse, NULL);
683 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
684 gfc_add_block_to_block (&se->pre, &tmpse.pre);
685 gfc_add_block_to_block (&se->post, &tmpse.post);
686 upper = fold_convert (gfc_array_index_type, tmpse.expr);
688 /* Set the upper bound of the loop to UPPER - LOWER. */
689 tmp = fold_build2_loc (input_location, MINUS_EXPR,
690 gfc_array_index_type, upper, lower);
691 tmp = gfc_evaluate_now (tmp, &se->pre);
692 se->loop->to[n] = tmp;
698 /* Generate code to allocate an array temporary, or create a variable to
699 hold the data. If size is NULL, zero the descriptor so that the
700 callee will allocate the array. If DEALLOC is true, also generate code to
701 free the array afterwards.
703 If INITIAL is not NULL, it is packed using internal_pack and the result used
704 as data instead of allocating a fresh, unitialized area of memory.
706 Initialization code is added to PRE and finalization code to POST.
707 DYNAMIC is true if the caller may want to extend the array later
708 using realloc. This prevents us from putting the array on the stack. */
711 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
712 gfc_array_info * info, tree size, tree nelem,
713 tree initial, bool dynamic, bool dealloc)
719 desc = info->descriptor;
720 info->offset = gfc_index_zero_node;
721 if (size == NULL_TREE || integer_zerop (size))
723 /* A callee allocated array. */
724 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
729 /* Allocate the temporary. */
730 onstack = !dynamic && initial == NULL_TREE
731 && (gfc_option.flag_stack_arrays
732 || gfc_can_put_var_on_stack (size));
736 /* Make a temporary variable to hold the data. */
737 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
738 nelem, gfc_index_one_node);
739 tmp = gfc_evaluate_now (tmp, pre);
740 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
742 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
744 tmp = gfc_create_var (tmp, "A");
745 /* If we're here only because of -fstack-arrays we have to
746 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
747 if (!gfc_can_put_var_on_stack (size))
748 gfc_add_expr_to_block (pre,
749 fold_build1_loc (input_location,
750 DECL_EXPR, TREE_TYPE (tmp),
752 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
753 gfc_conv_descriptor_data_set (pre, desc, tmp);
757 /* Allocate memory to hold the data or call internal_pack. */
758 if (initial == NULL_TREE)
760 tmp = gfc_call_malloc (pre, NULL, size);
761 tmp = gfc_evaluate_now (tmp, pre);
768 stmtblock_t do_copying;
770 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
771 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
772 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
773 tmp = gfc_get_element_type (tmp);
774 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
775 packed = gfc_create_var (build_pointer_type (tmp), "data");
777 tmp = build_call_expr_loc (input_location,
778 gfor_fndecl_in_pack, 1, initial);
779 tmp = fold_convert (TREE_TYPE (packed), tmp);
780 gfc_add_modify (pre, packed, tmp);
782 tmp = build_fold_indirect_ref_loc (input_location,
784 source_data = gfc_conv_descriptor_data_get (tmp);
786 /* internal_pack may return source->data without any allocation
787 or copying if it is already packed. If that's the case, we
788 need to allocate and copy manually. */
790 gfc_start_block (&do_copying);
791 tmp = gfc_call_malloc (&do_copying, NULL, size);
792 tmp = fold_convert (TREE_TYPE (packed), tmp);
793 gfc_add_modify (&do_copying, packed, tmp);
794 tmp = gfc_build_memcpy_call (packed, source_data, size);
795 gfc_add_expr_to_block (&do_copying, tmp);
797 was_packed = fold_build2_loc (input_location, EQ_EXPR,
798 boolean_type_node, packed,
800 tmp = gfc_finish_block (&do_copying);
801 tmp = build3_v (COND_EXPR, was_packed, tmp,
802 build_empty_stmt (input_location));
803 gfc_add_expr_to_block (pre, tmp);
805 tmp = fold_convert (pvoid_type_node, packed);
808 gfc_conv_descriptor_data_set (pre, desc, tmp);
811 info->data = gfc_conv_descriptor_data_get (desc);
813 /* The offset is zero because we create temporaries with a zero
815 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
817 if (dealloc && !onstack)
819 /* Free the temporary. */
820 tmp = gfc_conv_descriptor_data_get (desc);
821 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
822 gfc_add_expr_to_block (post, tmp);
827 /* Get the array reference dimension corresponding to the given loop dimension.
828 It is different from the true array dimension given by the dim array in
829 the case of a partial array reference
830 It is different from the loop dimension in the case of a transposed array.
834 get_array_ref_dim (gfc_ss *ss, int loop_dim)
836 int n, array_dim, array_ref_dim;
839 array_dim = ss->dim[loop_dim];
841 for (n = 0; n < ss->dimen; n++)
842 if (ss->dim[n] < array_dim)
845 return array_ref_dim;
849 /* Generate code to create and initialize the descriptor for a temporary
850 array. This is used for both temporaries needed by the scalarizer, and
851 functions returning arrays. Adjusts the loop variables to be
852 zero-based, and calculates the loop bounds for callee allocated arrays.
853 Allocate the array unless it's callee allocated (we have a callee
854 allocated array if 'callee_alloc' is true, or if loop->to[n] is
855 NULL_TREE for any n). Also fills in the descriptor, data and offset
856 fields of info if known. Returns the size of the array, or NULL for a
857 callee allocated array.
859 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
860 gfc_trans_allocate_array_storage.
864 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
865 gfc_loopinfo * loop, gfc_ss * ss,
866 tree eltype, tree initial, bool dynamic,
867 bool dealloc, bool callee_alloc, locus * where)
869 gfc_array_info *info;
870 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
880 memset (from, 0, sizeof (from));
881 memset (to, 0, sizeof (to));
883 info = &ss->data.info;
885 gcc_assert (ss->dimen > 0);
886 gcc_assert (loop->dimen == ss->dimen);
888 if (gfc_option.warn_array_temp && where)
889 gfc_warning ("Creating array temporary at %L", where);
891 /* Set the lower bound to zero. */
892 for (n = 0; n < loop->dimen; n++)
896 /* Callee allocated arrays may not have a known bound yet. */
898 loop->to[n] = gfc_evaluate_now (
899 fold_build2_loc (input_location, MINUS_EXPR,
900 gfc_array_index_type,
901 loop->to[n], loop->from[n]),
903 loop->from[n] = gfc_index_zero_node;
905 /* We are constructing the temporary's descriptor based on the loop
906 dimensions. As the dimensions may be accessed in arbitrary order
907 (think of transpose) the size taken from the n'th loop may not map
908 to the n'th dimension of the array. We need to reconstruct loop infos
909 in the right order before using it to set the descriptor
911 tmp_dim = get_array_ref_dim (ss, n);
912 from[tmp_dim] = loop->from[n];
913 to[tmp_dim] = loop->to[n];
915 info->delta[dim] = gfc_index_zero_node;
916 info->start[dim] = gfc_index_zero_node;
917 info->end[dim] = gfc_index_zero_node;
918 info->stride[dim] = gfc_index_one_node;
921 /* Initialize the descriptor. */
923 gfc_get_array_type_bounds (eltype, ss->dimen, 0, from, to, 1,
924 GFC_ARRAY_UNKNOWN, true);
925 desc = gfc_create_var (type, "atmp");
926 GFC_DECL_PACKED_ARRAY (desc) = 1;
928 info->descriptor = desc;
929 size = gfc_index_one_node;
931 /* Fill in the array dtype. */
932 tmp = gfc_conv_descriptor_dtype (desc);
933 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
936 Fill in the bounds and stride. This is a packed array, so:
939 for (n = 0; n < rank; n++)
942 delta = ubound[n] + 1 - lbound[n];
945 size = size * sizeof(element);
950 /* If there is at least one null loop->to[n], it is a callee allocated
952 for (n = 0; n < loop->dimen; n++)
953 if (loop->to[n] == NULL_TREE)
959 for (n = 0; n < loop->dimen; n++)
963 if (size == NULL_TREE)
965 /* For a callee allocated array express the loop bounds in terms
966 of the descriptor fields. */
967 tmp = fold_build2_loc (input_location,
968 MINUS_EXPR, gfc_array_index_type,
969 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
970 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
975 /* Store the stride and bound components in the descriptor. */
976 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
978 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
979 gfc_index_zero_node);
981 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n],
984 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
985 to[n], gfc_index_one_node);
987 /* Check whether the size for this dimension is negative. */
988 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp,
989 gfc_index_zero_node);
990 cond = gfc_evaluate_now (cond, pre);
995 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
996 boolean_type_node, or_expr, cond);
998 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1000 size = gfc_evaluate_now (size, pre);
1003 /* Get the size of the array. */
1005 if (size && !callee_alloc)
1007 /* If or_expr is true, then the extent in at least one
1008 dimension is zero and the size is set to zero. */
1009 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1010 or_expr, gfc_index_zero_node, size);
1013 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1015 fold_convert (gfc_array_index_type,
1016 TYPE_SIZE_UNIT (gfc_get_element_type (type))));
1024 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1027 if (ss->dimen > loop->temp_dim)
1028 loop->temp_dim = ss->dimen;
1034 /* Return the number of iterations in a loop that starts at START,
1035 ends at END, and has step STEP. */
1038 gfc_get_iteration_count (tree start, tree end, tree step)
1043 type = TREE_TYPE (step);
1044 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1045 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1046 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1047 build_int_cst (type, 1));
1048 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1049 build_int_cst (type, 0));
1050 return fold_convert (gfc_array_index_type, tmp);
1054 /* Extend the data in array DESC by EXTRA elements. */
1057 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1064 if (integer_zerop (extra))
1067 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1069 /* Add EXTRA to the upper bound. */
1070 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1072 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1074 /* Get the value of the current data pointer. */
1075 arg0 = gfc_conv_descriptor_data_get (desc);
1077 /* Calculate the new array size. */
1078 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1079 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1080 ubound, gfc_index_one_node);
1081 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1082 fold_convert (size_type_node, tmp),
1083 fold_convert (size_type_node, size));
1085 /* Call the realloc() function. */
1086 tmp = gfc_call_realloc (pblock, arg0, arg1);
1087 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1091 /* Return true if the bounds of iterator I can only be determined
1095 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1097 return (i->start->expr_type != EXPR_CONSTANT
1098 || i->end->expr_type != EXPR_CONSTANT
1099 || i->step->expr_type != EXPR_CONSTANT);
1103 /* Split the size of constructor element EXPR into the sum of two terms,
1104 one of which can be determined at compile time and one of which must
1105 be calculated at run time. Set *SIZE to the former and return true
1106 if the latter might be nonzero. */
1109 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1111 if (expr->expr_type == EXPR_ARRAY)
1112 return gfc_get_array_constructor_size (size, expr->value.constructor);
1113 else if (expr->rank > 0)
1115 /* Calculate everything at run time. */
1116 mpz_set_ui (*size, 0);
1121 /* A single element. */
1122 mpz_set_ui (*size, 1);
1128 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1129 of array constructor C. */
1132 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1140 mpz_set_ui (*size, 0);
1145 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1148 if (i && gfc_iterator_has_dynamic_bounds (i))
1152 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1155 /* Multiply the static part of the element size by the
1156 number of iterations. */
1157 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1158 mpz_fdiv_q (val, val, i->step->value.integer);
1159 mpz_add_ui (val, val, 1);
1160 if (mpz_sgn (val) > 0)
1161 mpz_mul (len, len, val);
1163 mpz_set_ui (len, 0);
1165 mpz_add (*size, *size, len);
1174 /* Make sure offset is a variable. */
1177 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1180 /* We should have already created the offset variable. We cannot
1181 create it here because we may be in an inner scope. */
1182 gcc_assert (*offsetvar != NULL_TREE);
1183 gfc_add_modify (pblock, *offsetvar, *poffset);
1184 *poffset = *offsetvar;
1185 TREE_USED (*offsetvar) = 1;
1189 /* Variables needed for bounds-checking. */
1190 static bool first_len;
1191 static tree first_len_val;
1192 static bool typespec_chararray_ctor;
1195 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1196 tree offset, gfc_se * se, gfc_expr * expr)
1200 gfc_conv_expr (se, expr);
1202 /* Store the value. */
1203 tmp = build_fold_indirect_ref_loc (input_location,
1204 gfc_conv_descriptor_data_get (desc));
1205 tmp = gfc_build_array_ref (tmp, offset, NULL);
1207 if (expr->ts.type == BT_CHARACTER)
1209 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1212 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1213 esize = fold_convert (gfc_charlen_type_node, esize);
1214 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1215 gfc_charlen_type_node, esize,
1216 build_int_cst (gfc_charlen_type_node,
1217 gfc_character_kinds[i].bit_size / 8));
1219 gfc_conv_string_parameter (se);
1220 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1222 /* The temporary is an array of pointers. */
1223 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1224 gfc_add_modify (&se->pre, tmp, se->expr);
1228 /* The temporary is an array of string values. */
1229 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1230 /* We know the temporary and the value will be the same length,
1231 so can use memcpy. */
1232 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1233 se->string_length, se->expr, expr->ts.kind);
1235 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1239 gfc_add_modify (&se->pre, first_len_val,
1245 /* Verify that all constructor elements are of the same
1247 tree cond = fold_build2_loc (input_location, NE_EXPR,
1248 boolean_type_node, first_len_val,
1250 gfc_trans_runtime_check
1251 (true, false, cond, &se->pre, &expr->where,
1252 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1253 fold_convert (long_integer_type_node, first_len_val),
1254 fold_convert (long_integer_type_node, se->string_length));
1260 /* TODO: Should the frontend already have done this conversion? */
1261 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1262 gfc_add_modify (&se->pre, tmp, se->expr);
1265 gfc_add_block_to_block (pblock, &se->pre);
1266 gfc_add_block_to_block (pblock, &se->post);
1270 /* Add the contents of an array to the constructor. DYNAMIC is as for
1271 gfc_trans_array_constructor_value. */
1274 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1275 tree type ATTRIBUTE_UNUSED,
1276 tree desc, gfc_expr * expr,
1277 tree * poffset, tree * offsetvar,
1288 /* We need this to be a variable so we can increment it. */
1289 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1291 gfc_init_se (&se, NULL);
1293 /* Walk the array expression. */
1294 ss = gfc_walk_expr (expr);
1295 gcc_assert (ss != gfc_ss_terminator);
1297 /* Initialize the scalarizer. */
1298 gfc_init_loopinfo (&loop);
1299 gfc_add_ss_to_loop (&loop, ss);
1301 /* Initialize the loop. */
1302 gfc_conv_ss_startstride (&loop);
1303 gfc_conv_loop_setup (&loop, &expr->where);
1305 /* Make sure the constructed array has room for the new data. */
1308 /* Set SIZE to the total number of elements in the subarray. */
1309 size = gfc_index_one_node;
1310 for (n = 0; n < loop.dimen; n++)
1312 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1313 gfc_index_one_node);
1314 size = fold_build2_loc (input_location, MULT_EXPR,
1315 gfc_array_index_type, size, tmp);
1318 /* Grow the constructed array by SIZE elements. */
1319 gfc_grow_array (&loop.pre, desc, size);
1322 /* Make the loop body. */
1323 gfc_mark_ss_chain_used (ss, 1);
1324 gfc_start_scalarized_body (&loop, &body);
1325 gfc_copy_loopinfo_to_se (&se, &loop);
1328 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1329 gcc_assert (se.ss == gfc_ss_terminator);
1331 /* Increment the offset. */
1332 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1333 *poffset, gfc_index_one_node);
1334 gfc_add_modify (&body, *poffset, tmp);
1336 /* Finish the loop. */
1337 gfc_trans_scalarizing_loops (&loop, &body);
1338 gfc_add_block_to_block (&loop.pre, &loop.post);
1339 tmp = gfc_finish_block (&loop.pre);
1340 gfc_add_expr_to_block (pblock, tmp);
1342 gfc_cleanup_loop (&loop);
1346 /* Assign the values to the elements of an array constructor. DYNAMIC
1347 is true if descriptor DESC only contains enough data for the static
1348 size calculated by gfc_get_array_constructor_size. When true, memory
1349 for the dynamic parts must be allocated using realloc. */
1352 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1353 tree desc, gfc_constructor_base base,
1354 tree * poffset, tree * offsetvar,
1363 tree shadow_loopvar = NULL_TREE;
1364 gfc_saved_var saved_loopvar;
1367 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1369 /* If this is an iterator or an array, the offset must be a variable. */
1370 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1371 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1373 /* Shadowing the iterator avoids changing its value and saves us from
1374 keeping track of it. Further, it makes sure that there's always a
1375 backend-decl for the symbol, even if there wasn't one before,
1376 e.g. in the case of an iterator that appears in a specification
1377 expression in an interface mapping. */
1380 gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1381 tree type = gfc_typenode_for_spec (&sym->ts);
1383 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1384 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1387 gfc_start_block (&body);
1389 if (c->expr->expr_type == EXPR_ARRAY)
1391 /* Array constructors can be nested. */
1392 gfc_trans_array_constructor_value (&body, type, desc,
1393 c->expr->value.constructor,
1394 poffset, offsetvar, dynamic);
1396 else if (c->expr->rank > 0)
1398 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1399 poffset, offsetvar, dynamic);
1403 /* This code really upsets the gimplifier so don't bother for now. */
1410 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1412 p = gfc_constructor_next (p);
1417 /* Scalar values. */
1418 gfc_init_se (&se, NULL);
1419 gfc_trans_array_ctor_element (&body, desc, *poffset,
1422 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1423 gfc_array_index_type,
1424 *poffset, gfc_index_one_node);
1428 /* Collect multiple scalar constants into a constructor. */
1429 VEC(constructor_elt,gc) *v = NULL;
1433 HOST_WIDE_INT idx = 0;
1436 /* Count the number of consecutive scalar constants. */
1437 while (p && !(p->iterator
1438 || p->expr->expr_type != EXPR_CONSTANT))
1440 gfc_init_se (&se, NULL);
1441 gfc_conv_constant (&se, p->expr);
1443 if (c->expr->ts.type != BT_CHARACTER)
1444 se.expr = fold_convert (type, se.expr);
1445 /* For constant character array constructors we build
1446 an array of pointers. */
1447 else if (POINTER_TYPE_P (type))
1448 se.expr = gfc_build_addr_expr
1449 (gfc_get_pchar_type (p->expr->ts.kind),
1452 CONSTRUCTOR_APPEND_ELT (v,
1453 build_int_cst (gfc_array_index_type,
1457 p = gfc_constructor_next (p);
1460 bound = size_int (n - 1);
1461 /* Create an array type to hold them. */
1462 tmptype = build_range_type (gfc_array_index_type,
1463 gfc_index_zero_node, bound);
1464 tmptype = build_array_type (type, tmptype);
1466 init = build_constructor (tmptype, v);
1467 TREE_CONSTANT (init) = 1;
1468 TREE_STATIC (init) = 1;
1469 /* Create a static variable to hold the data. */
1470 tmp = gfc_create_var (tmptype, "data");
1471 TREE_STATIC (tmp) = 1;
1472 TREE_CONSTANT (tmp) = 1;
1473 TREE_READONLY (tmp) = 1;
1474 DECL_INITIAL (tmp) = init;
1477 /* Use BUILTIN_MEMCPY to assign the values. */
1478 tmp = gfc_conv_descriptor_data_get (desc);
1479 tmp = build_fold_indirect_ref_loc (input_location,
1481 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1482 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1483 init = gfc_build_addr_expr (NULL_TREE, init);
1485 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1486 bound = build_int_cst (size_type_node, n * size);
1487 tmp = build_call_expr_loc (input_location,
1488 builtin_decl_explicit (BUILT_IN_MEMCPY),
1489 3, tmp, init, bound);
1490 gfc_add_expr_to_block (&body, tmp);
1492 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1493 gfc_array_index_type, *poffset,
1494 build_int_cst (gfc_array_index_type, n));
1496 if (!INTEGER_CST_P (*poffset))
1498 gfc_add_modify (&body, *offsetvar, *poffset);
1499 *poffset = *offsetvar;
1503 /* The frontend should already have done any expansions
1507 /* Pass the code as is. */
1508 tmp = gfc_finish_block (&body);
1509 gfc_add_expr_to_block (pblock, tmp);
1513 /* Build the implied do-loop. */
1514 stmtblock_t implied_do_block;
1522 loopbody = gfc_finish_block (&body);
1524 /* Create a new block that holds the implied-do loop. A temporary
1525 loop-variable is used. */
1526 gfc_start_block(&implied_do_block);
1528 /* Initialize the loop. */
1529 gfc_init_se (&se, NULL);
1530 gfc_conv_expr_val (&se, c->iterator->start);
1531 gfc_add_block_to_block (&implied_do_block, &se.pre);
1532 gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1534 gfc_init_se (&se, NULL);
1535 gfc_conv_expr_val (&se, c->iterator->end);
1536 gfc_add_block_to_block (&implied_do_block, &se.pre);
1537 end = gfc_evaluate_now (se.expr, &implied_do_block);
1539 gfc_init_se (&se, NULL);
1540 gfc_conv_expr_val (&se, c->iterator->step);
1541 gfc_add_block_to_block (&implied_do_block, &se.pre);
1542 step = gfc_evaluate_now (se.expr, &implied_do_block);
1544 /* If this array expands dynamically, and the number of iterations
1545 is not constant, we won't have allocated space for the static
1546 part of C->EXPR's size. Do that now. */
1547 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1549 /* Get the number of iterations. */
1550 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1552 /* Get the static part of C->EXPR's size. */
1553 gfc_get_array_constructor_element_size (&size, c->expr);
1554 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1556 /* Grow the array by TMP * TMP2 elements. */
1557 tmp = fold_build2_loc (input_location, MULT_EXPR,
1558 gfc_array_index_type, tmp, tmp2);
1559 gfc_grow_array (&implied_do_block, desc, tmp);
1562 /* Generate the loop body. */
1563 exit_label = gfc_build_label_decl (NULL_TREE);
1564 gfc_start_block (&body);
1566 /* Generate the exit condition. Depending on the sign of
1567 the step variable we have to generate the correct
1569 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1570 step, build_int_cst (TREE_TYPE (step), 0));
1571 cond = fold_build3_loc (input_location, COND_EXPR,
1572 boolean_type_node, tmp,
1573 fold_build2_loc (input_location, GT_EXPR,
1574 boolean_type_node, shadow_loopvar, end),
1575 fold_build2_loc (input_location, LT_EXPR,
1576 boolean_type_node, shadow_loopvar, end));
1577 tmp = build1_v (GOTO_EXPR, exit_label);
1578 TREE_USED (exit_label) = 1;
1579 tmp = build3_v (COND_EXPR, cond, tmp,
1580 build_empty_stmt (input_location));
1581 gfc_add_expr_to_block (&body, tmp);
1583 /* The main loop body. */
1584 gfc_add_expr_to_block (&body, loopbody);
1586 /* Increase loop variable by step. */
1587 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1588 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1590 gfc_add_modify (&body, shadow_loopvar, tmp);
1592 /* Finish the loop. */
1593 tmp = gfc_finish_block (&body);
1594 tmp = build1_v (LOOP_EXPR, tmp);
1595 gfc_add_expr_to_block (&implied_do_block, tmp);
1597 /* Add the exit label. */
1598 tmp = build1_v (LABEL_EXPR, exit_label);
1599 gfc_add_expr_to_block (&implied_do_block, tmp);
1601 /* Finishe the implied-do loop. */
1602 tmp = gfc_finish_block(&implied_do_block);
1603 gfc_add_expr_to_block(pblock, tmp);
1605 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1612 /* A catch-all to obtain the string length for anything that is not a
1613 a substring of non-constant length, a constant, array or variable. */
1616 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1621 /* Don't bother if we already know the length is a constant. */
1622 if (*len && INTEGER_CST_P (*len))
1625 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1626 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1629 gfc_conv_const_charlen (e->ts.u.cl);
1630 *len = e->ts.u.cl->backend_decl;
1634 /* Otherwise, be brutal even if inefficient. */
1635 ss = gfc_walk_expr (e);
1636 gfc_init_se (&se, NULL);
1638 /* No function call, in case of side effects. */
1639 se.no_function_call = 1;
1640 if (ss == gfc_ss_terminator)
1641 gfc_conv_expr (&se, e);
1643 gfc_conv_expr_descriptor (&se, e, ss);
1645 /* Fix the value. */
1646 *len = gfc_evaluate_now (se.string_length, &se.pre);
1648 gfc_add_block_to_block (block, &se.pre);
1649 gfc_add_block_to_block (block, &se.post);
1651 e->ts.u.cl->backend_decl = *len;
1656 /* Figure out the string length of a variable reference expression.
1657 Used by get_array_ctor_strlen. */
1660 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1666 /* Don't bother if we already know the length is a constant. */
1667 if (*len && INTEGER_CST_P (*len))
1670 ts = &expr->symtree->n.sym->ts;
1671 for (ref = expr->ref; ref; ref = ref->next)
1676 /* Array references don't change the string length. */
1680 /* Use the length of the component. */
1681 ts = &ref->u.c.component->ts;
1685 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1686 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1688 /* Note that this might evaluate expr. */
1689 get_array_ctor_all_strlen (block, expr, len);
1692 mpz_init_set_ui (char_len, 1);
1693 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1694 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1695 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1696 *len = convert (gfc_charlen_type_node, *len);
1697 mpz_clear (char_len);
1705 *len = ts->u.cl->backend_decl;
1709 /* Figure out the string length of a character array constructor.
1710 If len is NULL, don't calculate the length; this happens for recursive calls
1711 when a sub-array-constructor is an element but not at the first position,
1712 so when we're not interested in the length.
1713 Returns TRUE if all elements are character constants. */
1716 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1723 if (gfc_constructor_first (base) == NULL)
1726 *len = build_int_cstu (gfc_charlen_type_node, 0);
1730 /* Loop over all constructor elements to find out is_const, but in len we
1731 want to store the length of the first, not the last, element. We can
1732 of course exit the loop as soon as is_const is found to be false. */
1733 for (c = gfc_constructor_first (base);
1734 c && is_const; c = gfc_constructor_next (c))
1736 switch (c->expr->expr_type)
1739 if (len && !(*len && INTEGER_CST_P (*len)))
1740 *len = build_int_cstu (gfc_charlen_type_node,
1741 c->expr->value.character.length);
1745 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1752 get_array_ctor_var_strlen (block, c->expr, len);
1758 get_array_ctor_all_strlen (block, c->expr, len);
1762 /* After the first iteration, we don't want the length modified. */
1769 /* Check whether the array constructor C consists entirely of constant
1770 elements, and if so returns the number of those elements, otherwise
1771 return zero. Note, an empty or NULL array constructor returns zero. */
1773 unsigned HOST_WIDE_INT
1774 gfc_constant_array_constructor_p (gfc_constructor_base base)
1776 unsigned HOST_WIDE_INT nelem = 0;
1778 gfc_constructor *c = gfc_constructor_first (base);
1782 || c->expr->rank > 0
1783 || c->expr->expr_type != EXPR_CONSTANT)
1785 c = gfc_constructor_next (c);
1792 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1793 and the tree type of it's elements, TYPE, return a static constant
1794 variable that is compile-time initialized. */
1797 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1799 tree tmptype, init, tmp;
1800 HOST_WIDE_INT nelem;
1805 VEC(constructor_elt,gc) *v = NULL;
1807 /* First traverse the constructor list, converting the constants
1808 to tree to build an initializer. */
1810 c = gfc_constructor_first (expr->value.constructor);
1813 gfc_init_se (&se, NULL);
1814 gfc_conv_constant (&se, c->expr);
1815 if (c->expr->ts.type != BT_CHARACTER)
1816 se.expr = fold_convert (type, se.expr);
1817 else if (POINTER_TYPE_P (type))
1818 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1820 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
1822 c = gfc_constructor_next (c);
1826 /* Next determine the tree type for the array. We use the gfortran
1827 front-end's gfc_get_nodesc_array_type in order to create a suitable
1828 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
1830 memset (&as, 0, sizeof (gfc_array_spec));
1832 as.rank = expr->rank;
1833 as.type = AS_EXPLICIT;
1836 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1837 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1841 for (i = 0; i < expr->rank; i++)
1843 int tmp = (int) mpz_get_si (expr->shape[i]);
1844 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1845 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1849 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1851 /* as is not needed anymore. */
1852 for (i = 0; i < as.rank + as.corank; i++)
1854 gfc_free_expr (as.lower[i]);
1855 gfc_free_expr (as.upper[i]);
1858 init = build_constructor (tmptype, v);
1860 TREE_CONSTANT (init) = 1;
1861 TREE_STATIC (init) = 1;
1863 tmp = gfc_create_var (tmptype, "A");
1864 TREE_STATIC (tmp) = 1;
1865 TREE_CONSTANT (tmp) = 1;
1866 TREE_READONLY (tmp) = 1;
1867 DECL_INITIAL (tmp) = init;
1873 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1874 This mostly initializes the scalarizer state info structure with the
1875 appropriate values to directly use the array created by the function
1876 gfc_build_constant_array_constructor. */
1879 trans_constant_array_constructor (gfc_ss * ss, tree type)
1881 gfc_array_info *info;
1885 tmp = gfc_build_constant_array_constructor (ss->expr, type);
1887 info = &ss->data.info;
1889 info->descriptor = tmp;
1890 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1891 info->offset = gfc_index_zero_node;
1893 for (i = 0; i < ss->dimen; i++)
1895 info->delta[i] = gfc_index_zero_node;
1896 info->start[i] = gfc_index_zero_node;
1897 info->end[i] = gfc_index_zero_node;
1898 info->stride[i] = gfc_index_one_node;
1902 /* Helper routine of gfc_trans_array_constructor to determine if the
1903 bounds of the loop specified by LOOP are constant and simple enough
1904 to use with trans_constant_array_constructor. Returns the
1905 iteration count of the loop if suitable, and NULL_TREE otherwise. */
1908 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1910 tree size = gfc_index_one_node;
1914 for (i = 0; i < loop->dimen; i++)
1916 /* If the bounds aren't constant, return NULL_TREE. */
1917 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1919 if (!integer_zerop (loop->from[i]))
1921 /* Only allow nonzero "from" in one-dimensional arrays. */
1922 if (loop->dimen != 1)
1924 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1925 gfc_array_index_type,
1926 loop->to[i], loop->from[i]);
1930 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1931 tmp, gfc_index_one_node);
1932 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1940 /* Array constructors are handled by constructing a temporary, then using that
1941 within the scalarization loop. This is not optimal, but seems by far the
1945 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1947 gfc_constructor_base c;
1954 bool old_first_len, old_typespec_chararray_ctor;
1955 tree old_first_len_val;
1957 /* Save the old values for nested checking. */
1958 old_first_len = first_len;
1959 old_first_len_val = first_len_val;
1960 old_typespec_chararray_ctor = typespec_chararray_ctor;
1962 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1963 typespec was given for the array constructor. */
1964 typespec_chararray_ctor = (ss->expr->ts.u.cl
1965 && ss->expr->ts.u.cl->length_from_typespec);
1967 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1968 && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1970 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1974 gcc_assert (ss->dimen == loop->dimen);
1976 c = ss->expr->value.constructor;
1977 if (ss->expr->ts.type == BT_CHARACTER)
1981 /* get_array_ctor_strlen walks the elements of the constructor, if a
1982 typespec was given, we already know the string length and want the one
1984 if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1985 && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1989 const_string = false;
1990 gfc_init_se (&length_se, NULL);
1991 gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1992 gfc_charlen_type_node);
1993 ss->string_length = length_se.expr;
1994 gfc_add_block_to_block (&loop->pre, &length_se.pre);
1995 gfc_add_block_to_block (&loop->post, &length_se.post);
1998 const_string = get_array_ctor_strlen (&loop->pre, c,
1999 &ss->string_length);
2001 /* Complex character array constructors should have been taken care of
2002 and not end up here. */
2003 gcc_assert (ss->string_length);
2005 ss->expr->ts.u.cl->backend_decl = ss->string_length;
2007 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
2009 type = build_pointer_type (type);
2012 type = gfc_typenode_for_spec (&ss->expr->ts);
2014 /* See if the constructor determines the loop bounds. */
2017 if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
2019 /* We have a multidimensional parameter. */
2021 for (n = 0; n < ss->expr->rank; n++)
2023 loop->from[n] = gfc_index_zero_node;
2024 loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
2025 gfc_index_integer_kind);
2026 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2027 gfc_array_index_type,
2028 loop->to[n], gfc_index_one_node);
2032 if (loop->to[0] == NULL_TREE)
2036 /* We should have a 1-dimensional, zero-based loop. */
2037 gcc_assert (loop->dimen == 1);
2038 gcc_assert (integer_zerop (loop->from[0]));
2040 /* Split the constructor size into a static part and a dynamic part.
2041 Allocate the static size up-front and record whether the dynamic
2042 size might be nonzero. */
2044 dynamic = gfc_get_array_constructor_size (&size, c);
2045 mpz_sub_ui (size, size, 1);
2046 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2050 /* Special case constant array constructors. */
2053 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2056 tree size = constant_array_constructor_loop_size (loop);
2057 if (size && compare_tree_int (size, nelem) == 0)
2059 trans_constant_array_constructor (ss, type);
2065 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2068 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, ss,
2069 type, NULL_TREE, dynamic, true, false, where);
2071 desc = ss->data.info.descriptor;
2072 offset = gfc_index_zero_node;
2073 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2074 TREE_NO_WARNING (offsetvar) = 1;
2075 TREE_USED (offsetvar) = 0;
2076 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2077 &offset, &offsetvar, dynamic);
2079 /* If the array grows dynamically, the upper bound of the loop variable
2080 is determined by the array's final upper bound. */
2083 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2084 gfc_array_index_type,
2085 offsetvar, gfc_index_one_node);
2086 tmp = gfc_evaluate_now (tmp, &loop->pre);
2087 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2088 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2089 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2094 if (TREE_USED (offsetvar))
2095 pushdecl (offsetvar);
2097 gcc_assert (INTEGER_CST_P (offset));
2100 /* Disable bound checking for now because it's probably broken. */
2101 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2108 /* Restore old values of globals. */
2109 first_len = old_first_len;
2110 first_len_val = old_first_len_val;
2111 typespec_chararray_ctor = old_typespec_chararray_ctor;
2115 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2116 called after evaluating all of INFO's vector dimensions. Go through
2117 each such vector dimension and see if we can now fill in any missing
2121 set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss)
2123 gfc_array_info *info;
2131 info = &ss->data.info;
2133 for (n = 0; n < loop->dimen; n++)
2136 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2137 && loop->to[n] == NULL)
2139 /* Loop variable N indexes vector dimension DIM, and we don't
2140 yet know the upper bound of loop variable N. Set it to the
2141 difference between the vector's upper and lower bounds. */
2142 gcc_assert (loop->from[n] == gfc_index_zero_node);
2143 gcc_assert (info->subscript[dim]
2144 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2146 gfc_init_se (&se, NULL);
2147 desc = info->subscript[dim]->data.info.descriptor;
2148 zero = gfc_rank_cst[0];
2149 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2150 gfc_array_index_type,
2151 gfc_conv_descriptor_ubound_get (desc, zero),
2152 gfc_conv_descriptor_lbound_get (desc, zero));
2153 tmp = gfc_evaluate_now (tmp, &loop->pre);
2160 /* Add the pre and post chains for all the scalar expressions in a SS chain
2161 to loop. This is called after the loop parameters have been calculated,
2162 but before the actual scalarizing loops. */
2165 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2171 /* TODO: This can generate bad code if there are ordering dependencies,
2172 e.g., a callee allocated function and an unknown size constructor. */
2173 gcc_assert (ss != NULL);
2175 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2179 switch (ss->info->type)
2182 /* Scalar expression. Evaluate this now. This includes elemental
2183 dimension indices, but not array section bounds. */
2184 gfc_init_se (&se, NULL);
2185 gfc_conv_expr (&se, ss->expr);
2186 gfc_add_block_to_block (&loop->pre, &se.pre);
2188 if (ss->expr->ts.type != BT_CHARACTER)
2190 /* Move the evaluation of scalar expressions outside the
2191 scalarization loop, except for WHERE assignments. */
2193 se.expr = convert(gfc_array_index_type, se.expr);
2195 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2196 gfc_add_block_to_block (&loop->pre, &se.post);
2199 gfc_add_block_to_block (&loop->post, &se.post);
2201 ss->data.scalar.expr = se.expr;
2202 ss->string_length = se.string_length;
2205 case GFC_SS_REFERENCE:
2206 /* Scalar argument to elemental procedure. Evaluate this
2208 gfc_init_se (&se, NULL);
2209 gfc_conv_expr (&se, ss->expr);
2210 gfc_add_block_to_block (&loop->pre, &se.pre);
2211 gfc_add_block_to_block (&loop->post, &se.post);
2213 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2214 ss->string_length = se.string_length;
2217 case GFC_SS_SECTION:
2218 /* Add the expressions for scalar and vector subscripts. */
2219 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2220 if (ss->data.info.subscript[n])
2221 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2224 set_vector_loop_bounds (loop, ss);
2228 /* Get the vector's descriptor and store it in SS. */
2229 gfc_init_se (&se, NULL);
2230 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2231 gfc_add_block_to_block (&loop->pre, &se.pre);
2232 gfc_add_block_to_block (&loop->post, &se.post);
2233 ss->data.info.descriptor = se.expr;
2236 case GFC_SS_INTRINSIC:
2237 gfc_add_intrinsic_ss_code (loop, ss);
2240 case GFC_SS_FUNCTION:
2241 /* Array function return value. We call the function and save its
2242 result in a temporary for use inside the loop. */
2243 gfc_init_se (&se, NULL);
2246 gfc_conv_expr (&se, ss->expr);
2247 gfc_add_block_to_block (&loop->pre, &se.pre);
2248 gfc_add_block_to_block (&loop->post, &se.post);
2249 ss->string_length = se.string_length;
2252 case GFC_SS_CONSTRUCTOR:
2253 if (ss->expr->ts.type == BT_CHARACTER
2254 && ss->string_length == NULL
2255 && ss->expr->ts.u.cl
2256 && ss->expr->ts.u.cl->length)
2258 gfc_init_se (&se, NULL);
2259 gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2260 gfc_charlen_type_node);
2261 ss->string_length = se.expr;
2262 gfc_add_block_to_block (&loop->pre, &se.pre);
2263 gfc_add_block_to_block (&loop->post, &se.post);
2265 gfc_trans_array_constructor (loop, ss, where);
2269 case GFC_SS_COMPONENT:
2270 /* Do nothing. These are handled elsewhere. */
2280 /* Translate expressions for the descriptor and data pointer of a SS. */
2284 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2289 /* Get the descriptor for the array to be scalarized. */
2290 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2291 gfc_init_se (&se, NULL);
2292 se.descriptor_only = 1;
2293 gfc_conv_expr_lhs (&se, ss->expr);
2294 gfc_add_block_to_block (block, &se.pre);
2295 ss->data.info.descriptor = se.expr;
2296 ss->string_length = se.string_length;
2300 /* Also the data pointer. */
2301 tmp = gfc_conv_array_data (se.expr);
2302 /* If this is a variable or address of a variable we use it directly.
2303 Otherwise we must evaluate it now to avoid breaking dependency
2304 analysis by pulling the expressions for elemental array indices
2307 || (TREE_CODE (tmp) == ADDR_EXPR
2308 && DECL_P (TREE_OPERAND (tmp, 0)))))
2309 tmp = gfc_evaluate_now (tmp, block);
2310 ss->data.info.data = tmp;
2312 tmp = gfc_conv_array_offset (se.expr);
2313 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2315 /* Make absolutely sure that the saved_offset is indeed saved
2316 so that the variable is still accessible after the loops
2318 ss->data.info.saved_offset = ss->data.info.offset;
2323 /* Initialize a gfc_loopinfo structure. */
2326 gfc_init_loopinfo (gfc_loopinfo * loop)
2330 memset (loop, 0, sizeof (gfc_loopinfo));
2331 gfc_init_block (&loop->pre);
2332 gfc_init_block (&loop->post);
2334 /* Initially scalarize in order and default to no loop reversal. */
2335 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2338 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2341 loop->ss = gfc_ss_terminator;
2345 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2349 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2355 /* Return an expression for the data pointer of an array. */
2358 gfc_conv_array_data (tree descriptor)
2362 type = TREE_TYPE (descriptor);
2363 if (GFC_ARRAY_TYPE_P (type))
2365 if (TREE_CODE (type) == POINTER_TYPE)
2369 /* Descriptorless arrays. */
2370 return gfc_build_addr_expr (NULL_TREE, descriptor);
2374 return gfc_conv_descriptor_data_get (descriptor);
2378 /* Return an expression for the base offset of an array. */
2381 gfc_conv_array_offset (tree descriptor)
2385 type = TREE_TYPE (descriptor);
2386 if (GFC_ARRAY_TYPE_P (type))
2387 return GFC_TYPE_ARRAY_OFFSET (type);
2389 return gfc_conv_descriptor_offset_get (descriptor);
2393 /* Get an expression for the array stride. */
2396 gfc_conv_array_stride (tree descriptor, int dim)
2401 type = TREE_TYPE (descriptor);
2403 /* For descriptorless arrays use the array size. */
2404 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2405 if (tmp != NULL_TREE)
2408 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2413 /* Like gfc_conv_array_stride, but for the lower bound. */
2416 gfc_conv_array_lbound (tree descriptor, int dim)
2421 type = TREE_TYPE (descriptor);
2423 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2424 if (tmp != NULL_TREE)
2427 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2432 /* Like gfc_conv_array_stride, but for the upper bound. */
2435 gfc_conv_array_ubound (tree descriptor, int dim)
2440 type = TREE_TYPE (descriptor);
2442 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2443 if (tmp != NULL_TREE)
2446 /* This should only ever happen when passing an assumed shape array
2447 as an actual parameter. The value will never be used. */
2448 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2449 return gfc_index_zero_node;
2451 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2456 /* Generate code to perform an array index bound check. */
2459 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2460 locus * where, bool check_upper)
2463 tree tmp_lo, tmp_up;
2466 const char * name = NULL;
2468 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2471 descriptor = ss->data.info.descriptor;
2473 index = gfc_evaluate_now (index, &se->pre);
2475 /* We find a name for the error message. */
2476 name = ss->expr->symtree->n.sym->name;
2477 gcc_assert (name != NULL);
2479 if (TREE_CODE (descriptor) == VAR_DECL)
2480 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2482 /* If upper bound is present, include both bounds in the error message. */
2485 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2486 tmp_up = gfc_conv_array_ubound (descriptor, n);
2489 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2490 "outside of expected range (%%ld:%%ld)", n+1, name);
2492 asprintf (&msg, "Index '%%ld' of dimension %d "
2493 "outside of expected range (%%ld:%%ld)", n+1);
2495 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2497 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2498 fold_convert (long_integer_type_node, index),
2499 fold_convert (long_integer_type_node, tmp_lo),
2500 fold_convert (long_integer_type_node, tmp_up));
2501 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2503 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2504 fold_convert (long_integer_type_node, index),
2505 fold_convert (long_integer_type_node, tmp_lo),
2506 fold_convert (long_integer_type_node, tmp_up));
2511 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2514 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2515 "below lower bound of %%ld", n+1, name);
2517 asprintf (&msg, "Index '%%ld' of dimension %d "
2518 "below lower bound of %%ld", n+1);
2520 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2522 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2523 fold_convert (long_integer_type_node, index),
2524 fold_convert (long_integer_type_node, tmp_lo));
2532 /* Return the offset for an index. Performs bound checking for elemental
2533 dimensions. Single element references are processed separately.
2534 DIM is the array dimension, I is the loop dimension. */
2537 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2538 gfc_array_ref * ar, tree stride)
2540 gfc_array_info *info;
2545 info = &ss->data.info;
2547 /* Get the index into the array for this dimension. */
2550 gcc_assert (ar->type != AR_ELEMENT);
2551 switch (ar->dimen_type[dim])
2553 case DIMEN_THIS_IMAGE:
2557 /* Elemental dimension. */
2558 gcc_assert (info->subscript[dim]
2559 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2560 /* We've already translated this value outside the loop. */
2561 index = info->subscript[dim]->data.scalar.expr;
2563 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2564 ar->as->type != AS_ASSUMED_SIZE
2565 || dim < ar->dimen - 1);
2569 gcc_assert (info && se->loop);
2570 gcc_assert (info->subscript[dim]
2571 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2572 desc = info->subscript[dim]->data.info.descriptor;
2574 /* Get a zero-based index into the vector. */
2575 index = fold_build2_loc (input_location, MINUS_EXPR,
2576 gfc_array_index_type,
2577 se->loop->loopvar[i], se->loop->from[i]);
2579 /* Multiply the index by the stride. */
2580 index = fold_build2_loc (input_location, MULT_EXPR,
2581 gfc_array_index_type,
2582 index, gfc_conv_array_stride (desc, 0));
2584 /* Read the vector to get an index into info->descriptor. */
2585 data = build_fold_indirect_ref_loc (input_location,
2586 gfc_conv_array_data (desc));
2587 index = gfc_build_array_ref (data, index, NULL);
2588 index = gfc_evaluate_now (index, &se->pre);
2589 index = fold_convert (gfc_array_index_type, index);
2591 /* Do any bounds checking on the final info->descriptor index. */
2592 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2593 ar->as->type != AS_ASSUMED_SIZE
2594 || dim < ar->dimen - 1);
2598 /* Scalarized dimension. */
2599 gcc_assert (info && se->loop);
2601 /* Multiply the loop variable by the stride and delta. */
2602 index = se->loop->loopvar[i];
2603 if (!integer_onep (info->stride[dim]))
2604 index = fold_build2_loc (input_location, MULT_EXPR,
2605 gfc_array_index_type, index,
2607 if (!integer_zerop (info->delta[dim]))
2608 index = fold_build2_loc (input_location, PLUS_EXPR,
2609 gfc_array_index_type, index,
2619 /* Temporary array or derived type component. */
2620 gcc_assert (se->loop);
2621 index = se->loop->loopvar[se->loop->order[i]];
2623 /* Pointer functions can have stride[0] different from unity.
2624 Use the stride returned by the function call and stored in
2625 the descriptor for the temporary. */
2626 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2628 && se->ss->expr->symtree
2629 && se->ss->expr->symtree->n.sym->result
2630 && se->ss->expr->symtree->n.sym->result->attr.pointer)
2631 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2634 if (!integer_zerop (info->delta[dim]))
2635 index = fold_build2_loc (input_location, PLUS_EXPR,
2636 gfc_array_index_type, index, info->delta[dim]);
2639 /* Multiply by the stride. */
2640 if (!integer_onep (stride))
2641 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2648 /* Build a scalarized reference to an array. */
2651 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2653 gfc_array_info *info;
2654 tree decl = NULL_TREE;
2661 info = &ss->data.info;
2663 n = se->loop->order[0];
2667 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
2668 /* Add the offset for this dimension to the stored offset for all other
2670 if (!integer_zerop (info->offset))
2671 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2672 index, info->offset);
2674 if (se->ss->expr && is_subref_array (se->ss->expr))
2675 decl = se->ss->expr->symtree->n.sym->backend_decl;
2677 tmp = build_fold_indirect_ref_loc (input_location,
2679 se->expr = gfc_build_array_ref (tmp, index, decl);
2683 /* Translate access of temporary array. */
2686 gfc_conv_tmp_array_ref (gfc_se * se)
2688 se->string_length = se->ss->string_length;
2689 gfc_conv_scalarized_array_ref (se, NULL);
2690 gfc_advance_se_ss_chain (se);
2693 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2696 add_to_offset (tree *cst_offset, tree *offset, tree t)
2698 if (TREE_CODE (t) == INTEGER_CST)
2699 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2702 if (!integer_zerop (*offset))
2703 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2704 gfc_array_index_type, *offset, t);
2710 /* Build an array reference. se->expr already holds the array descriptor.
2711 This should be either a variable, indirect variable reference or component
2712 reference. For arrays which do not have a descriptor, se->expr will be
2714 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2717 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2721 tree offset, cst_offset;
2729 gcc_assert (ar->codimen);
2731 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2732 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2735 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2736 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2737 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2739 /* Use the actual tree type and not the wrapped coarray. */
2740 if (!se->want_pointer)
2741 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2748 /* Handle scalarized references separately. */
2749 if (ar->type != AR_ELEMENT)
2751 gfc_conv_scalarized_array_ref (se, ar);
2752 gfc_advance_se_ss_chain (se);
2756 cst_offset = offset = gfc_index_zero_node;
2757 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2759 /* Calculate the offsets from all the dimensions. Make sure to associate
2760 the final offset so that we form a chain of loop invariant summands. */
2761 for (n = ar->dimen - 1; n >= 0; n--)
2763 /* Calculate the index for this dimension. */
2764 gfc_init_se (&indexse, se);
2765 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2766 gfc_add_block_to_block (&se->pre, &indexse.pre);
2768 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2770 /* Check array bounds. */
2774 /* Evaluate the indexse.expr only once. */
2775 indexse.expr = save_expr (indexse.expr);
2778 tmp = gfc_conv_array_lbound (se->expr, n);
2779 if (sym->attr.temporary)
2781 gfc_init_se (&tmpse, se);
2782 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2783 gfc_array_index_type);
2784 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2788 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2790 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2791 "below lower bound of %%ld", n+1, sym->name);
2792 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2793 fold_convert (long_integer_type_node,
2795 fold_convert (long_integer_type_node, tmp));
2798 /* Upper bound, but not for the last dimension of assumed-size
2800 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2802 tmp = gfc_conv_array_ubound (se->expr, n);
2803 if (sym->attr.temporary)
2805 gfc_init_se (&tmpse, se);
2806 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2807 gfc_array_index_type);
2808 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2812 cond = fold_build2_loc (input_location, GT_EXPR,
2813 boolean_type_node, indexse.expr, tmp);
2814 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2815 "above upper bound of %%ld", n+1, sym->name);
2816 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2817 fold_convert (long_integer_type_node,
2819 fold_convert (long_integer_type_node, tmp));
2824 /* Multiply the index by the stride. */
2825 stride = gfc_conv_array_stride (se->expr, n);
2826 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2827 indexse.expr, stride);
2829 /* And add it to the total. */
2830 add_to_offset (&cst_offset, &offset, tmp);
2833 if (!integer_zerop (cst_offset))
2834 offset = fold_build2_loc (input_location, PLUS_EXPR,
2835 gfc_array_index_type, offset, cst_offset);
2837 /* Access the calculated element. */
2838 tmp = gfc_conv_array_data (se->expr);
2839 tmp = build_fold_indirect_ref (tmp);
2840 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2844 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
2845 LOOP_DIM dimension (if any) to array's offset. */
2848 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
2849 gfc_array_ref *ar, int array_dim, int loop_dim)
2852 gfc_array_info *info;
2855 info = &ss->data.info;
2857 gfc_init_se (&se, NULL);
2859 se.expr = info->descriptor;
2860 stride = gfc_conv_array_stride (info->descriptor, array_dim);
2861 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
2862 gfc_add_block_to_block (pblock, &se.pre);
2864 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2865 gfc_array_index_type,
2866 info->offset, index);
2867 info->offset = gfc_evaluate_now (info->offset, pblock);
2871 /* Generate the code to be executed immediately before entering a
2872 scalarization loop. */
2875 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2876 stmtblock_t * pblock)
2879 gfc_array_info *info;
2880 gfc_ss_type ss_type;
2885 /* This code will be executed before entering the scalarization loop
2886 for this dimension. */
2887 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2889 if ((ss->useflags & flag) == 0)
2892 ss_type = ss->info->type;
2893 if (ss_type != GFC_SS_SECTION
2894 && ss_type != GFC_SS_FUNCTION
2895 && ss_type != GFC_SS_CONSTRUCTOR
2896 && ss_type != GFC_SS_COMPONENT)
2899 info = &ss->data.info;
2901 gcc_assert (dim < ss->dimen);
2902 gcc_assert (ss->dimen == loop->dimen);
2905 ar = &info->ref->u.ar;
2909 if (dim == loop->dimen - 1)
2914 /* For the time being, there is no loop reordering. */
2915 gcc_assert (i == loop->order[i]);
2918 if (dim == loop->dimen - 1)
2920 stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]);
2922 /* Calculate the stride of the innermost loop. Hopefully this will
2923 allow the backend optimizers to do their stuff more effectively.
2925 info->stride0 = gfc_evaluate_now (stride, pblock);
2927 /* For the outermost loop calculate the offset due to any
2928 elemental dimensions. It will have been initialized with the
2929 base offset of the array. */
2932 for (i = 0; i < ar->dimen; i++)
2934 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2937 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
2942 /* Add the offset for the previous loop dimension. */
2943 add_array_offset (pblock, loop, ss, ar, ss->dim[i], i);
2945 /* Remember this offset for the second loop. */
2946 if (dim == loop->temp_dim - 1)
2947 info->saved_offset = info->offset;
2952 /* Start a scalarized expression. Creates a scope and declares loop
2956 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2962 gcc_assert (!loop->array_parameter);
2964 for (dim = loop->dimen - 1; dim >= 0; dim--)
2966 n = loop->order[dim];
2968 gfc_start_block (&loop->code[n]);
2970 /* Create the loop variable. */
2971 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2973 if (dim < loop->temp_dim)
2977 /* Calculate values that will be constant within this loop. */
2978 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2980 gfc_start_block (pbody);
2984 /* Generates the actual loop code for a scalarization loop. */
2987 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2988 stmtblock_t * pbody)
2999 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3000 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3001 && n == loop->dimen - 1)
3003 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3004 init = make_tree_vec (1);
3005 cond = make_tree_vec (1);
3006 incr = make_tree_vec (1);
3008 /* Cycle statement is implemented with a goto. Exit statement must not
3009 be present for this loop. */
3010 exit_label = gfc_build_label_decl (NULL_TREE);
3011 TREE_USED (exit_label) = 1;
3013 /* Label for cycle statements (if needed). */
3014 tmp = build1_v (LABEL_EXPR, exit_label);
3015 gfc_add_expr_to_block (pbody, tmp);
3017 stmt = make_node (OMP_FOR);
3019 TREE_TYPE (stmt) = void_type_node;
3020 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3022 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3023 OMP_CLAUSE_SCHEDULE);
3024 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3025 = OMP_CLAUSE_SCHEDULE_STATIC;
3026 if (ompws_flags & OMPWS_NOWAIT)
3027 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3028 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3030 /* Initialize the loopvar. */
3031 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3033 OMP_FOR_INIT (stmt) = init;
3034 /* The exit condition. */
3035 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3037 loop->loopvar[n], loop->to[n]);
3038 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3039 OMP_FOR_COND (stmt) = cond;
3040 /* Increment the loopvar. */
3041 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3042 loop->loopvar[n], gfc_index_one_node);
3043 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3044 void_type_node, loop->loopvar[n], tmp);
3045 OMP_FOR_INCR (stmt) = incr;
3047 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3048 gfc_add_expr_to_block (&loop->code[n], stmt);
3052 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3053 && (loop->temp_ss == NULL);
3055 loopbody = gfc_finish_block (pbody);
3059 tmp = loop->from[n];
3060 loop->from[n] = loop->to[n];
3064 /* Initialize the loopvar. */
3065 if (loop->loopvar[n] != loop->from[n])
3066 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3068 exit_label = gfc_build_label_decl (NULL_TREE);
3070 /* Generate the loop body. */
3071 gfc_init_block (&block);
3073 /* The exit condition. */
3074 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3075 boolean_type_node, loop->loopvar[n], loop->to[n]);
3076 tmp = build1_v (GOTO_EXPR, exit_label);
3077 TREE_USED (exit_label) = 1;
3078 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3079 gfc_add_expr_to_block (&block, tmp);
3081 /* The main body. */
3082 gfc_add_expr_to_block (&block, loopbody);
3084 /* Increment the loopvar. */
3085 tmp = fold_build2_loc (input_location,
3086 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3087 gfc_array_index_type, loop->loopvar[n],
3088 gfc_index_one_node);
3090 gfc_add_modify (&block, loop->loopvar[n], tmp);
3092 /* Build the loop. */
3093 tmp = gfc_finish_block (&block);
3094 tmp = build1_v (LOOP_EXPR, tmp);
3095 gfc_add_expr_to_block (&loop->code[n], tmp);
3097 /* Add the exit label. */
3098 tmp = build1_v (LABEL_EXPR, exit_label);
3099 gfc_add_expr_to_block (&loop->code[n], tmp);
3105 /* Finishes and generates the loops for a scalarized expression. */
3108 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3113 stmtblock_t *pblock;
3117 /* Generate the loops. */
3118 for (dim = 0; dim < loop->dimen; dim++)
3120 n = loop->order[dim];
3121 gfc_trans_scalarized_loop_end (loop, n, pblock);
3122 loop->loopvar[n] = NULL_TREE;
3123 pblock = &loop->code[n];
3126 tmp = gfc_finish_block (pblock);
3127 gfc_add_expr_to_block (&loop->pre, tmp);
3129 /* Clear all the used flags. */
3130 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3135 /* Finish the main body of a scalarized expression, and start the secondary
3139 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3143 stmtblock_t *pblock;
3147 /* We finish as many loops as are used by the temporary. */
3148 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3150 n = loop->order[dim];
3151 gfc_trans_scalarized_loop_end (loop, n, pblock);
3152 loop->loopvar[n] = NULL_TREE;
3153 pblock = &loop->code[n];
3156 /* We don't want to finish the outermost loop entirely. */
3157 n = loop->order[loop->temp_dim - 1];
3158 gfc_trans_scalarized_loop_end (loop, n, pblock);
3160 /* Restore the initial offsets. */
3161 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3163 gfc_ss_type ss_type;
3165 if ((ss->useflags & 2) == 0)
3168 ss_type = ss->info->type;
3169 if (ss_type != GFC_SS_SECTION
3170 && ss_type != GFC_SS_FUNCTION
3171 && ss_type != GFC_SS_CONSTRUCTOR
3172 && ss_type != GFC_SS_COMPONENT)
3175 ss->data.info.offset = ss->data.info.saved_offset;
3178 /* Restart all the inner loops we just finished. */
3179 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3181 n = loop->order[dim];
3183 gfc_start_block (&loop->code[n]);
3185 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3187 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3190 /* Start a block for the secondary copying code. */
3191 gfc_start_block (body);
3195 /* Precalculate (either lower or upper) bound of an array section.
3196 BLOCK: Block in which the (pre)calculation code will go.
3197 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3198 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3199 DESC: Array descriptor from which the bound will be picked if unspecified
3200 (either lower or upper bound according to LBOUND). */
3203 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3204 tree desc, int dim, bool lbound)
3207 gfc_expr * input_val = values[dim];
3208 tree *output = &bounds[dim];
3213 /* Specified section bound. */
3214 gfc_init_se (&se, NULL);
3215 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3216 gfc_add_block_to_block (block, &se.pre);
3221 /* No specific bound specified so use the bound of the array. */
3222 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3223 gfc_conv_array_ubound (desc, dim);
3225 *output = gfc_evaluate_now (*output, block);
3229 /* Calculate the lower bound of an array section. */
3232 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3234 gfc_expr *stride = NULL;
3237 gfc_array_info *info;
3240 gcc_assert (ss->info->type == GFC_SS_SECTION);
3242 info = &ss->data.info;
3243 ar = &info->ref->u.ar;
3245 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3247 /* We use a zero-based index to access the vector. */
3248 info->start[dim] = gfc_index_zero_node;
3249 info->end[dim] = NULL;
3250 info->stride[dim] = gfc_index_one_node;
3254 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3255 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3256 desc = info->descriptor;
3257 stride = ar->stride[dim];
3259 /* Calculate the start of the range. For vector subscripts this will
3260 be the range of the vector. */
3261 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3263 /* Similarly calculate the end. Although this is not used in the
3264 scalarizer, it is needed when checking bounds and where the end
3265 is an expression with side-effects. */
3266 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3268 /* Calculate the stride. */
3270 info->stride[dim] = gfc_index_one_node;
3273 gfc_init_se (&se, NULL);
3274 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3275 gfc_add_block_to_block (&loop->pre, &se.pre);
3276 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3281 /* Calculates the range start and stride for a SS chain. Also gets the
3282 descriptor and data pointer. The range of vector subscripts is the size
3283 of the vector. Array bounds are also checked. */
3286 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3294 /* Determine the rank of the loop. */
3295 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3297 switch (ss->info->type)
3299 case GFC_SS_SECTION:
3300 case GFC_SS_CONSTRUCTOR:
3301 case GFC_SS_FUNCTION:
3302 case GFC_SS_COMPONENT:
3303 loop->dimen = ss->dimen;
3306 /* As usual, lbound and ubound are exceptions!. */
3307 case GFC_SS_INTRINSIC:
3308 switch (ss->expr->value.function.isym->id)
3310 case GFC_ISYM_LBOUND:
3311 case GFC_ISYM_UBOUND:
3312 case GFC_ISYM_LCOBOUND:
3313 case GFC_ISYM_UCOBOUND:
3314 case GFC_ISYM_THIS_IMAGE:
3315 loop->dimen = ss->dimen;
3327 /* We should have determined the rank of the expression by now. If
3328 not, that's bad news. */
3332 /* Loop over all the SS in the chain. */
3333 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3335 gfc_array_info *info;
3337 info = &ss->data.info;
3339 if (ss->expr && ss->expr->shape && !info->shape)
3340 info->shape = ss->expr->shape;
3342 switch (ss->info->type)
3344 case GFC_SS_SECTION:
3345 /* Get the descriptor for the array. */
3346 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3348 for (n = 0; n < ss->dimen; n++)
3349 gfc_conv_section_startstride (loop, ss, ss->dim[n]);
3352 case GFC_SS_INTRINSIC:
3353 switch (ss->expr->value.function.isym->id)
3355 /* Fall through to supply start and stride. */
3356 case GFC_ISYM_LBOUND:
3357 case GFC_ISYM_UBOUND:
3358 case GFC_ISYM_LCOBOUND:
3359 case GFC_ISYM_UCOBOUND:
3360 case GFC_ISYM_THIS_IMAGE:
3367 case GFC_SS_CONSTRUCTOR:
3368 case GFC_SS_FUNCTION:
3369 for (n = 0; n < ss->dimen; n++)
3371 int dim = ss->dim[n];
3373 ss->data.info.start[dim] = gfc_index_zero_node;
3374 ss->data.info.end[dim] = gfc_index_zero_node;
3375 ss->data.info.stride[dim] = gfc_index_one_node;
3384 /* The rest is just runtime bound checking. */
3385 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3388 tree lbound, ubound;
3390 tree size[GFC_MAX_DIMENSIONS];
3391 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3392 gfc_array_info *info;
3396 gfc_start_block (&block);
3398 for (n = 0; n < loop->dimen; n++)
3399 size[n] = NULL_TREE;
3401 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3405 if (ss->info->type != GFC_SS_SECTION)
3408 /* Catch allocatable lhs in f2003. */
3409 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3412 gfc_start_block (&inner);
3414 /* TODO: range checking for mapped dimensions. */
3415 info = &ss->data.info;
3417 /* This code only checks ranges. Elemental and vector
3418 dimensions are checked later. */
3419 for (n = 0; n < loop->dimen; n++)
3424 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3427 if (dim == info->ref->u.ar.dimen - 1
3428 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3429 check_upper = false;
3433 /* Zero stride is not allowed. */
3434 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3435 info->stride[dim], gfc_index_zero_node);
3436 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3437 "of array '%s'", dim + 1, ss->expr->symtree->name);
3438 gfc_trans_runtime_check (true, false, tmp, &inner,
3439 &ss->expr->where, msg);
3442 desc = ss->data.info.descriptor;
3444 /* This is the run-time equivalent of resolve.c's
3445 check_dimension(). The logical is more readable there
3446 than it is here, with all the trees. */
3447 lbound = gfc_conv_array_lbound (desc, dim);
3448 end = info->end[dim];
3450 ubound = gfc_conv_array_ubound (desc, dim);
3454 /* non_zerosized is true when the selected range is not
3456 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3457 boolean_type_node, info->stride[dim],
3458 gfc_index_zero_node);
3459 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3460 info->start[dim], end);
3461 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3462 boolean_type_node, stride_pos, tmp);
3464 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3466 info->stride[dim], gfc_index_zero_node);
3467 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3468 info->start[dim], end);
3469 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3472 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3474 stride_pos, stride_neg);
3476 /* Check the start of the range against the lower and upper
3477 bounds of the array, if the range is not empty.
3478 If upper bound is present, include both bounds in the
3482 tmp = fold_build2_loc (input_location, LT_EXPR,
3484 info->start[dim], lbound);
3485 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3487 non_zerosized, tmp);
3488 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3490 info->start[dim], ubound);
3491 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3493 non_zerosized, tmp2);
3494 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3495 "outside of expected range (%%ld:%%ld)",
3496 dim + 1, ss->expr->symtree->name);
3497 gfc_trans_runtime_check (true, false, tmp, &inner,
3498 &ss->expr->where, msg,
3499 fold_convert (long_integer_type_node, info->start[dim]),
3500 fold_convert (long_integer_type_node, lbound),
3501 fold_convert (long_integer_type_node, ubound));
3502 gfc_trans_runtime_check (true, false, tmp2, &inner,
3503 &ss->expr->where, msg,
3504 fold_convert (long_integer_type_node, info->start[dim]),
3505 fold_convert (long_integer_type_node, lbound),
3506 fold_convert (long_integer_type_node, ubound));
3511 tmp = fold_build2_loc (input_location, LT_EXPR,
3513 info->start[dim], lbound);
3514 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3515 boolean_type_node, non_zerosized, tmp);
3516 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3517 "below lower bound of %%ld",
3518 dim + 1, ss->expr->symtree->name);
3519 gfc_trans_runtime_check (true, false, tmp, &inner,
3520 &ss->expr->where, msg,
3521 fold_convert (long_integer_type_node, info->start[dim]),
3522 fold_convert (long_integer_type_node, lbound));
3526 /* Compute the last element of the range, which is not
3527 necessarily "end" (think 0:5:3, which doesn't contain 5)
3528 and check it against both lower and upper bounds. */
3530 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3531 gfc_array_index_type, end,
3533 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3534 gfc_array_index_type, tmp,
3536 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3537 gfc_array_index_type, end, tmp);
3538 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3539 boolean_type_node, tmp, lbound);
3540 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3541 boolean_type_node, non_zerosized, tmp2);
3544 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3545 boolean_type_node, tmp, ubound);
3546 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3547 boolean_type_node, non_zerosized, tmp3);
3548 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3549 "outside of expected range (%%ld:%%ld)",
3550 dim + 1, ss->expr->symtree->name);
3551 gfc_trans_runtime_check (true, false, tmp2, &inner,
3552 &ss->expr->where, msg,
3553 fold_convert (long_integer_type_node, tmp),
3554 fold_convert (long_integer_type_node, ubound),
3555 fold_convert (long_integer_type_node, lbound));
3556 gfc_trans_runtime_check (true, false, tmp3, &inner,
3557 &ss->expr->where, msg,
3558 fold_convert (long_integer_type_node, tmp),
3559 fold_convert (long_integer_type_node, ubound),
3560 fold_convert (long_integer_type_node, lbound));
3565 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3566 "below lower bound of %%ld",
3567 dim + 1, ss->expr->symtree->name);
3568 gfc_trans_runtime_check (true, false, tmp2, &inner,
3569 &ss->expr->where, msg,
3570 fold_convert (long_integer_type_node, tmp),
3571 fold_convert (long_integer_type_node, lbound));
3575 /* Check the section sizes match. */
3576 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3577 gfc_array_index_type, end,
3579 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3580 gfc_array_index_type, tmp,
3582 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3583 gfc_array_index_type,
3584 gfc_index_one_node, tmp);
3585 tmp = fold_build2_loc (input_location, MAX_EXPR,
3586 gfc_array_index_type, tmp,
3587 build_int_cst (gfc_array_index_type, 0));
3588 /* We remember the size of the first section, and check all the
3589 others against this. */
3592 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3593 boolean_type_node, tmp, size[n]);
3594 asprintf (&msg, "Array bound mismatch for dimension %d "
3595 "of array '%s' (%%ld/%%ld)",
3596 dim + 1, ss->expr->symtree->name);
3598 gfc_trans_runtime_check (true, false, tmp3, &inner,
3599 &ss->expr->where, msg,
3600 fold_convert (long_integer_type_node, tmp),
3601 fold_convert (long_integer_type_node, size[n]));
3606 size[n] = gfc_evaluate_now (tmp, &inner);
3609 tmp = gfc_finish_block (&inner);
3611 /* For optional arguments, only check bounds if the argument is
3613 if (ss->expr->symtree->n.sym->attr.optional
3614 || ss->expr->symtree->n.sym->attr.not_always_present)
3615 tmp = build3_v (COND_EXPR,
3616 gfc_conv_expr_present (ss->expr->symtree->n.sym),
3617 tmp, build_empty_stmt (input_location));
3619 gfc_add_expr_to_block (&block, tmp);
3623 tmp = gfc_finish_block (&block);
3624 gfc_add_expr_to_block (&loop->pre, tmp);
3628 /* Return true if both symbols could refer to the same data object. Does
3629 not take account of aliasing due to equivalence statements. */
3632 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3633 bool lsym_target, bool rsym_pointer, bool rsym_target)
3635 /* Aliasing isn't possible if the symbols have different base types. */
3636 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3639 /* Pointers can point to other pointers and target objects. */
3641 if ((lsym_pointer && (rsym_pointer || rsym_target))
3642 || (rsym_pointer && (lsym_pointer || lsym_target)))
3645 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3646 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3648 if (lsym_target && rsym_target
3649 && ((lsym->attr.dummy && !lsym->attr.contiguous
3650 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3651 || (rsym->attr.dummy && !rsym->attr.contiguous
3652 && (!rsym->attr.dimension
3653 || rsym->as->type == AS_ASSUMED_SHAPE))))
3660 /* Return true if the two SS could be aliased, i.e. both point to the same data
3662 /* TODO: resolve aliases based on frontend expressions. */
3665 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3671 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3673 lsym = lss->expr->symtree->n.sym;
3674 rsym = rss->expr->symtree->n.sym;
3676 lsym_pointer = lsym->attr.pointer;
3677 lsym_target = lsym->attr.target;
3678 rsym_pointer = rsym->attr.pointer;
3679 rsym_target = rsym->attr.target;
3681 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3682 rsym_pointer, rsym_target))
3685 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3686 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3689 /* For derived types we must check all the component types. We can ignore
3690 array references as these will have the same base type as the previous
3692 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3694 if (lref->type != REF_COMPONENT)
3697 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3698 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3700 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3701 rsym_pointer, rsym_target))
3704 if ((lsym_pointer && (rsym_pointer || rsym_target))
3705 || (rsym_pointer && (lsym_pointer || lsym_target)))
3707 if (gfc_compare_types (&lref->u.c.component->ts,
3712 for (rref = rss->expr->ref; rref != rss->data.info.ref;
3715 if (rref->type != REF_COMPONENT)
3718 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3719 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3721 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3722 lsym_pointer, lsym_target,
3723 rsym_pointer, rsym_target))
3726 if ((lsym_pointer && (rsym_pointer || rsym_target))
3727 || (rsym_pointer && (lsym_pointer || lsym_target)))
3729 if (gfc_compare_types (&lref->u.c.component->ts,
3730 &rref->u.c.sym->ts))
3732 if (gfc_compare_types (&lref->u.c.sym->ts,
3733 &rref->u.c.component->ts))
3735 if (gfc_compare_types (&lref->u.c.component->ts,
3736 &rref->u.c.component->ts))
3742 lsym_pointer = lsym->attr.pointer;
3743 lsym_target = lsym->attr.target;
3744 lsym_pointer = lsym->attr.pointer;
3745 lsym_target = lsym->attr.target;
3747 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3749 if (rref->type != REF_COMPONENT)
3752 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3753 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3755 if (symbols_could_alias (rref->u.c.sym, lsym,
3756 lsym_pointer, lsym_target,
3757 rsym_pointer, rsym_target))
3760 if ((lsym_pointer && (rsym_pointer || rsym_target))
3761 || (rsym_pointer && (lsym_pointer || lsym_target)))
3763 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3772 /* Resolve array data dependencies. Creates a temporary if required. */
3773 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3777 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3786 loop->temp_ss = NULL;
3788 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3790 if (ss->info->type != GFC_SS_SECTION)
3793 if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3795 if (gfc_could_be_alias (dest, ss)
3796 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3804 lref = dest->expr->ref;
3805 rref = ss->expr->ref;
3807 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3812 for (i = 0; i < dest->dimen; i++)
3813 for (j = 0; j < ss->dimen; j++)
3815 && dest->dim[i] == ss->dim[j])
3817 /* If we don't access array elements in the same order,
3818 there is a dependency. */
3823 /* TODO : loop shifting. */
3826 /* Mark the dimensions for LOOP SHIFTING */
3827 for (n = 0; n < loop->dimen; n++)
3829 int dim = dest->data.info.dim[n];
3831 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3833 else if (! gfc_is_same_range (&lref->u.ar,
3834 &rref->u.ar, dim, 0))
3838 /* Put all the dimensions with dependencies in the
3841 for (n = 0; n < loop->dimen; n++)
3843 gcc_assert (loop->order[n] == n);
3845 loop->order[dim++] = n;
3847 for (n = 0; n < loop->dimen; n++)
3850 loop->order[dim++] = n;
3853 gcc_assert (dim == loop->dimen);
3864 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3865 if (GFC_ARRAY_TYPE_P (base_type)
3866 || GFC_DESCRIPTOR_TYPE_P (base_type))
3867 base_type = gfc_get_element_type (base_type);
3868 loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
3870 gfc_add_ss_to_loop (loop, loop->temp_ss);
3873 loop->temp_ss = NULL;
3877 /* Initialize the scalarization loop. Creates the loop variables. Determines
3878 the range of the loop variables. Creates a temporary if required.
3879 Calculates how to transform from loop variables to array indices for each
3880 expression. Also generates code for scalar expressions which have been
3881 moved outside the loop. */
3884 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3886 int n, dim, spec_dim;
3887 gfc_array_info *info;
3888 gfc_array_info *specinfo;
3889 gfc_ss *ss, *tmp_ss;
3891 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3892 bool dynamic[GFC_MAX_DIMENSIONS];
3897 for (n = 0; n < loop->dimen; n++)
3901 /* We use one SS term, and use that to determine the bounds of the
3902 loop for this dimension. We try to pick the simplest term. */
3903 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3905 gfc_ss_type ss_type;
3907 ss_type = ss->info->type;
3908 if (ss_type == GFC_SS_SCALAR
3909 || ss_type == GFC_SS_TEMP
3910 || ss_type == GFC_SS_REFERENCE)
3913 info = &ss->data.info;
3916 if (loopspec[n] != NULL)
3918 specinfo = &loopspec[n]->data.info;
3919 spec_dim = loopspec[n]->dim[n];
3923 /* Silence unitialized warnings. */
3930 gcc_assert (info->shape[dim]);
3931 /* The frontend has worked out the size for us. */
3934 || !integer_zerop (specinfo->start[spec_dim]))
3935 /* Prefer zero-based descriptors if possible. */
3940 if (ss_type == GFC_SS_CONSTRUCTOR)
3942 gfc_constructor_base base;
3943 /* An unknown size constructor will always be rank one.
3944 Higher rank constructors will either have known shape,
3945 or still be wrapped in a call to reshape. */
3946 gcc_assert (loop->dimen == 1);
3948 /* Always prefer to use the constructor bounds if the size
3949 can be determined at compile time. Prefer not to otherwise,
3950 since the general case involves realloc, and it's better to
3951 avoid that overhead if possible. */
3952 base = ss->expr->value.constructor;
3953 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3954 if (!dynamic[n] || !loopspec[n])
3959 /* TODO: Pick the best bound if we have a choice between a
3960 function and something else. */
3961 if (ss_type == GFC_SS_FUNCTION)
3967 /* Avoid using an allocatable lhs in an assignment, since
3968 there might be a reallocation coming. */
3969 if (loopspec[n] && ss->is_alloc_lhs)
3972 if (ss_type != GFC_SS_SECTION)
3977 /* Criteria for choosing a loop specifier (most important first):
3978 doesn't need realloc
3984 else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3985 || n >= loop->dimen)
3987 else if (integer_onep (info->stride[dim])
3988 && !integer_onep (specinfo->stride[spec_dim]))
3990 else if (INTEGER_CST_P (info->stride[dim])
3991 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
3993 else if (INTEGER_CST_P (info->start[dim])
3994 && !INTEGER_CST_P (specinfo->start[spec_dim]))
3996 /* We don't work out the upper bound.
3997 else if (INTEGER_CST_P (info->finish[n])
3998 && ! INTEGER_CST_P (specinfo->finish[n]))
3999 loopspec[n] = ss; */
4002 /* We should have found the scalarization loop specifier. If not,
4004 gcc_assert (loopspec[n]);
4006 info = &loopspec[n]->data.info;
4007 dim = loopspec[n]->dim[n];
4009 /* Set the extents of this range. */
4010 cshape = info->shape;
4011 if (cshape && INTEGER_CST_P (info->start[dim])
4012 && INTEGER_CST_P (info->stride[dim]))
4014 loop->from[n] = info->start[dim];
4015 mpz_set (i, cshape[get_array_ref_dim (loopspec[n], n)]);
4016 mpz_sub_ui (i, i, 1);
4017 /* To = from + (size - 1) * stride. */
4018 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4019 if (!integer_onep (info->stride[dim]))
4020 tmp = fold_build2_loc (input_location, MULT_EXPR,
4021 gfc_array_index_type, tmp,
4023 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4024 gfc_array_index_type,
4025 loop->from[n], tmp);
4029 loop->from[n] = info->start[dim];
4030 switch (loopspec[n]->info->type)
4032 case GFC_SS_CONSTRUCTOR:
4033 /* The upper bound is calculated when we expand the
4035 gcc_assert (loop->to[n] == NULL_TREE);
4038 case GFC_SS_SECTION:
4039 /* Use the end expression if it exists and is not constant,
4040 so that it is only evaluated once. */
4041 loop->to[n] = info->end[dim];
4044 case GFC_SS_FUNCTION:
4045 /* The loop bound will be set when we generate the call. */
4046 gcc_assert (loop->to[n] == NULL_TREE);
4054 /* Transform everything so we have a simple incrementing variable. */
4055 if (n < loop->dimen && integer_onep (info->stride[dim]))
4056 info->delta[dim] = gfc_index_zero_node;
4057 else if (n < loop->dimen)
4059 /* Set the delta for this section. */
4060 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4061 /* Number of iterations is (end - start + step) / step.
4062 with start = 0, this simplifies to
4064 for (i = 0; i<=last; i++){...}; */
4065 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4066 gfc_array_index_type, loop->to[n],
4068 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4069 gfc_array_index_type, tmp, info->stride[dim]);
4070 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4071 tmp, build_int_cst (gfc_array_index_type, -1));
4072 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4073 /* Make the loop variable start at 0. */
4074 loop->from[n] = gfc_index_zero_node;
4078 /* Add all the scalar code that can be taken out of the loops.
4079 This may include calculating the loop bounds, so do it before
4080 allocating the temporary. */
4081 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4083 tmp_ss = loop->temp_ss;
4084 /* If we want a temporary then create it. */
4087 gfc_ss_info *tmp_ss_info;
4089 tmp_ss_info = tmp_ss->info;
4090 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4092 /* Make absolutely sure that this is a complete type. */
4093 if (loop->temp_ss->string_length)
4094 loop->temp_ss->data.temp.type
4095 = gfc_get_character_type_len_for_eltype
4096 (TREE_TYPE (loop->temp_ss->data.temp.type),
4097 loop->temp_ss->string_length);
4099 tmp = loop->temp_ss->data.temp.type;
4100 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_array_info));
4101 tmp_ss_info->type = GFC_SS_SECTION;
4103 gcc_assert (tmp_ss->dimen != 0);
4105 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4106 tmp_ss, tmp, NULL_TREE,
4107 false, true, false, where);
4110 for (n = 0; n < loop->temp_dim; n++)
4111 loopspec[loop->order[n]] = NULL;
4115 /* For array parameters we don't have loop variables, so don't calculate the
4117 if (loop->array_parameter)
4120 /* Calculate the translation from loop variables to array indices. */
4121 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4123 gfc_ss_type ss_type;
4125 ss_type = ss->info->type;
4126 if (ss_type != GFC_SS_SECTION
4127 && ss_type != GFC_SS_COMPONENT
4128 && ss_type != GFC_SS_CONSTRUCTOR)
4131 info = &ss->data.info;
4133 for (n = 0; n < ss->dimen; n++)
4135 /* If we are specifying the range the delta is already set. */
4136 if (loopspec[n] != ss)
4140 /* Calculate the offset relative to the loop variable.
4141 First multiply by the stride. */
4142 tmp = loop->from[n];
4143 if (!integer_onep (info->stride[dim]))
4144 tmp = fold_build2_loc (input_location, MULT_EXPR,
4145 gfc_array_index_type,
4146 tmp, info->stride[dim]);
4148 /* Then subtract this from our starting value. */
4149 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4150 gfc_array_index_type,
4151 info->start[dim], tmp);
4153 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4160 /* Calculate the size of a given array dimension from the bounds. This
4161 is simply (ubound - lbound + 1) if this expression is positive
4162 or 0 if it is negative (pick either one if it is zero). Optionally
4163 (if or_expr is present) OR the (expression != 0) condition to it. */
4166 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4171 /* Calculate (ubound - lbound + 1). */
4172 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4174 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4175 gfc_index_one_node);
4177 /* Check whether the size for this dimension is negative. */
4178 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4179 gfc_index_zero_node);
4180 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4181 gfc_index_zero_node, res);
4183 /* Build OR expression. */
4185 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4186 boolean_type_node, *or_expr, cond);
4192 /* For an array descriptor, get the total number of elements. This is just
4193 the product of the extents along from_dim to to_dim. */
4196 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4201 res = gfc_index_one_node;
4203 for (dim = from_dim; dim < to_dim; ++dim)
4209 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4210 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4212 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4213 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4221 /* Full size of an array. */
4224 gfc_conv_descriptor_size (tree desc, int rank)
4226 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4230 /* Size of a coarray for all dimensions but the last. */
4233 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4235 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4239 /* Fills in an array descriptor, and returns the size of the array.
4240 The size will be a simple_val, ie a variable or a constant. Also
4241 calculates the offset of the base. The pointer argument overflow,
4242 which should be of integer type, will increase in value if overflow
4243 occurs during the size calculation. Returns the size of the array.
4247 for (n = 0; n < rank; n++)
4249 a.lbound[n] = specified_lower_bound;
4250 offset = offset + a.lbond[n] * stride;
4252 a.ubound[n] = specified_upper_bound;
4253 a.stride[n] = stride;
4254 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4255 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4256 stride = stride * size;
4258 for (n = rank; n < rank+corank; n++)
4259 (Set lcobound/ucobound as above.)
4260 element_size = sizeof (array element);
4263 stride = (size_t) stride;
4264 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4265 stride = stride * element_size;
4271 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4272 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4273 stmtblock_t * descriptor_block, tree * overflow)
4286 stmtblock_t thenblock;
4287 stmtblock_t elseblock;
4292 type = TREE_TYPE (descriptor);
4294 stride = gfc_index_one_node;
4295 offset = gfc_index_zero_node;
4297 /* Set the dtype. */
4298 tmp = gfc_conv_descriptor_dtype (descriptor);
4299 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4301 or_expr = boolean_false_node;
4303 for (n = 0; n < rank; n++)
4308 /* We have 3 possibilities for determining the size of the array:
4309 lower == NULL => lbound = 1, ubound = upper[n]
4310 upper[n] = NULL => lbound = 1, ubound = lower[n]
4311 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4314 /* Set lower bound. */
4315 gfc_init_se (&se, NULL);
4317 se.expr = gfc_index_one_node;
4320 gcc_assert (lower[n]);
4323 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4324 gfc_add_block_to_block (pblock, &se.pre);
4328 se.expr = gfc_index_one_node;
4332 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4333 gfc_rank_cst[n], se.expr);
4334 conv_lbound = se.expr;
4336 /* Work out the offset for this component. */
4337 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4339 offset = fold_build2_loc (input_location, MINUS_EXPR,
4340 gfc_array_index_type, offset, tmp);
4342 /* Set upper bound. */
4343 gfc_init_se (&se, NULL);
4344 gcc_assert (ubound);
4345 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4346 gfc_add_block_to_block (pblock, &se.pre);
4348 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4349 gfc_rank_cst[n], se.expr);
4350 conv_ubound = se.expr;
4352 /* Store the stride. */
4353 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4354 gfc_rank_cst[n], stride);
4356 /* Calculate size and check whether extent is negative. */
4357 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4358 size = gfc_evaluate_now (size, pblock);
4360 /* Check whether multiplying the stride by the number of
4361 elements in this dimension would overflow. We must also check
4362 whether the current dimension has zero size in order to avoid
4365 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4366 gfc_array_index_type,
4367 fold_convert (gfc_array_index_type,
4368 TYPE_MAX_VALUE (gfc_array_index_type)),
4370 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4371 boolean_type_node, tmp, stride));
4372 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4373 integer_one_node, integer_zero_node);
4374 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4375 boolean_type_node, size,
4376 gfc_index_zero_node));
4377 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4378 integer_zero_node, tmp);
4379 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4381 *overflow = gfc_evaluate_now (tmp, pblock);
4383 /* Multiply the stride by the number of elements in this dimension. */
4384 stride = fold_build2_loc (input_location, MULT_EXPR,
4385 gfc_array_index_type, stride, size);
4386 stride = gfc_evaluate_now (stride, pblock);
4389 for (n = rank; n < rank + corank; n++)
4393 /* Set lower bound. */
4394 gfc_init_se (&se, NULL);
4395 if (lower == NULL || lower[n] == NULL)
4397 gcc_assert (n == rank + corank - 1);
4398 se.expr = gfc_index_one_node;
4402 if (ubound || n == rank + corank - 1)
4404 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4405 gfc_add_block_to_block (pblock, &se.pre);
4409 se.expr = gfc_index_one_node;
4413 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4414 gfc_rank_cst[n], se.expr);
4416 if (n < rank + corank - 1)
4418 gfc_init_se (&se, NULL);
4419 gcc_assert (ubound);
4420 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4421 gfc_add_block_to_block (pblock, &se.pre);
4422 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4423 gfc_rank_cst[n], se.expr);
4427 /* The stride is the number of elements in the array, so multiply by the
4428 size of an element to get the total size. */
4429 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4430 /* Convert to size_t. */
4431 element_size = fold_convert (size_type_node, tmp);
4434 return element_size;
4436 stride = fold_convert (size_type_node, stride);
4438 /* First check for overflow. Since an array of type character can
4439 have zero element_size, we must check for that before
4441 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4443 TYPE_MAX_VALUE (size_type_node), element_size);
4444 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4445 boolean_type_node, tmp, stride));
4446 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4447 integer_one_node, integer_zero_node);
4448 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4449 boolean_type_node, element_size,
4450 build_int_cst (size_type_node, 0)));
4451 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4452 integer_zero_node, tmp);
4453 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4455 *overflow = gfc_evaluate_now (tmp, pblock);
4457 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4458 stride, element_size);
4460 if (poffset != NULL)
4462 offset = gfc_evaluate_now (offset, pblock);
4466 if (integer_zerop (or_expr))
4468 if (integer_onep (or_expr))
4469 return build_int_cst (size_type_node, 0);
4471 var = gfc_create_var (TREE_TYPE (size), "size");
4472 gfc_start_block (&thenblock);
4473 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4474 thencase = gfc_finish_block (&thenblock);
4476 gfc_start_block (&elseblock);
4477 gfc_add_modify (&elseblock, var, size);
4478 elsecase = gfc_finish_block (&elseblock);
4480 tmp = gfc_evaluate_now (or_expr, pblock);
4481 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4482 gfc_add_expr_to_block (pblock, tmp);
4488 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4489 the work for an ALLOCATE statement. */
4493 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4498 tree offset = NULL_TREE;
4499 tree token = NULL_TREE;
4502 tree error = NULL_TREE;
4503 tree overflow; /* Boolean storing whether size calculation overflows. */
4504 tree var_overflow = NULL_TREE;
4506 tree set_descriptor;
4507 stmtblock_t set_descriptor_block;
4508 stmtblock_t elseblock;
4511 gfc_ref *ref, *prev_ref = NULL;
4512 bool allocatable, coarray, dimension;
4516 /* Find the last reference in the chain. */
4517 while (ref && ref->next != NULL)
4519 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4520 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4525 if (ref == NULL || ref->type != REF_ARRAY)
4530 allocatable = expr->symtree->n.sym->attr.allocatable;
4531 coarray = expr->symtree->n.sym->attr.codimension;
4532 dimension = expr->symtree->n.sym->attr.dimension;
4536 allocatable = prev_ref->u.c.component->attr.allocatable;
4537 coarray = prev_ref->u.c.component->attr.codimension;
4538 dimension = prev_ref->u.c.component->attr.dimension;
4542 gcc_assert (coarray);
4544 /* Figure out the size of the array. */
4545 switch (ref->u.ar.type)
4551 upper = ref->u.ar.start;
4557 lower = ref->u.ar.start;
4558 upper = ref->u.ar.end;
4562 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4564 lower = ref->u.ar.as->lower;
4565 upper = ref->u.ar.as->upper;
4573 overflow = integer_zero_node;
4575 gfc_init_block (&set_descriptor_block);
4576 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4577 ref->u.ar.as->corank, &offset, lower, upper,
4578 &se->pre, &set_descriptor_block, &overflow);
4583 var_overflow = gfc_create_var (integer_type_node, "overflow");
4584 gfc_add_modify (&se->pre, var_overflow, overflow);
4586 /* Generate the block of code handling overflow. */
4587 msg = gfc_build_addr_expr (pchar_type_node,
4588 gfc_build_localized_cstring_const
4589 ("Integer overflow when calculating the amount of "
4590 "memory to allocate"));
4591 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4595 if (status != NULL_TREE)
4597 tree status_type = TREE_TYPE (status);
4598 stmtblock_t set_status_block;
4600 gfc_start_block (&set_status_block);
4601 gfc_add_modify (&set_status_block, status,
4602 build_int_cst (status_type, LIBERROR_ALLOCATION));
4603 error = gfc_finish_block (&set_status_block);
4606 gfc_start_block (&elseblock);
4608 /* Allocate memory to store the data. */
4609 pointer = gfc_conv_descriptor_data_get (se->expr);
4610 STRIP_NOPS (pointer);
4612 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4613 token = gfc_build_addr_expr (NULL_TREE,
4614 gfc_conv_descriptor_token (se->expr));
4616 /* The allocatable variant takes the old pointer as first argument. */
4618 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4619 status, errmsg, errlen, expr);
4621 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4625 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4626 boolean_type_node, var_overflow, integer_zero_node));
4627 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4628 error, gfc_finish_block (&elseblock));
4631 tmp = gfc_finish_block (&elseblock);
4633 gfc_add_expr_to_block (&se->pre, tmp);
4635 /* Update the array descriptors. */
4637 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4639 set_descriptor = gfc_finish_block (&set_descriptor_block);
4640 if (status != NULL_TREE)
4642 cond = fold_build2_loc (input_location, EQ_EXPR,
4643 boolean_type_node, status,
4644 build_int_cst (TREE_TYPE (status), 0));
4645 gfc_add_expr_to_block (&se->pre,
4646 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4647 gfc_likely (cond), set_descriptor,
4648 build_empty_stmt (input_location)));
4651 gfc_add_expr_to_block (&se->pre, set_descriptor);
4653 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4654 && expr->ts.u.derived->attr.alloc_comp)
4656 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4657 ref->u.ar.as->rank);
4658 gfc_add_expr_to_block (&se->pre, tmp);
4665 /* Deallocate an array variable. Also used when an allocated variable goes
4670 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4676 gfc_start_block (&block);
4677 /* Get a pointer to the data. */
4678 var = gfc_conv_descriptor_data_get (descriptor);
4681 /* Parameter is the address of the data component. */
4682 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4683 gfc_add_expr_to_block (&block, tmp);
4685 /* Zero the data pointer. */
4686 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4687 var, build_int_cst (TREE_TYPE (var), 0));
4688 gfc_add_expr_to_block (&block, tmp);
4690 return gfc_finish_block (&block);
4694 /* Create an array constructor from an initialization expression.
4695 We assume the frontend already did any expansions and conversions. */
4698 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4704 unsigned HOST_WIDE_INT lo;
4706 VEC(constructor_elt,gc) *v = NULL;
4708 switch (expr->expr_type)
4711 case EXPR_STRUCTURE:
4712 /* A single scalar or derived type value. Create an array with all
4713 elements equal to that value. */
4714 gfc_init_se (&se, NULL);
4716 if (expr->expr_type == EXPR_CONSTANT)
4717 gfc_conv_constant (&se, expr);
4719 gfc_conv_structure (&se, expr, 1);
4721 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4722 gcc_assert (tmp && INTEGER_CST_P (tmp));
4723 hi = TREE_INT_CST_HIGH (tmp);
4724 lo = TREE_INT_CST_LOW (tmp);
4728 /* This will probably eat buckets of memory for large arrays. */
4729 while (hi != 0 || lo != 0)
4731 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4739 /* Create a vector of all the elements. */
4740 for (c = gfc_constructor_first (expr->value.constructor);
4741 c; c = gfc_constructor_next (c))
4745 /* Problems occur when we get something like
4746 integer :: a(lots) = (/(i, i=1, lots)/) */
4747 gfc_fatal_error ("The number of elements in the array constructor "
4748 "at %L requires an increase of the allowed %d "
4749 "upper limit. See -fmax-array-constructor "
4750 "option", &expr->where,
4751 gfc_option.flag_max_array_constructor);
4754 if (mpz_cmp_si (c->offset, 0) != 0)
4755 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4759 if (mpz_cmp_si (c->repeat, 1) > 0)
4765 mpz_add (maxval, c->offset, c->repeat);
4766 mpz_sub_ui (maxval, maxval, 1);
4767 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4768 if (mpz_cmp_si (c->offset, 0) != 0)
4770 mpz_add_ui (maxval, c->offset, 1);
4771 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4774 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4776 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4782 gfc_init_se (&se, NULL);
4783 switch (c->expr->expr_type)
4786 gfc_conv_constant (&se, c->expr);
4789 case EXPR_STRUCTURE:
4790 gfc_conv_structure (&se, c->expr, 1);
4794 /* Catch those occasional beasts that do not simplify
4795 for one reason or another, assuming that if they are
4796 standard defying the frontend will catch them. */
4797 gfc_conv_expr (&se, c->expr);
4801 if (range == NULL_TREE)
4802 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4805 if (index != NULL_TREE)
4806 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4807 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4813 return gfc_build_null_descriptor (type);
4819 /* Create a constructor from the list of elements. */
4820 tmp = build_constructor (type, v);
4821 TREE_CONSTANT (tmp) = 1;
4826 /* Generate code to evaluate non-constant coarray cobounds. */
4829 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4830 const gfc_symbol *sym)
4840 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4842 /* Evaluate non-constant array bound expressions. */
4843 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4844 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4846 gfc_init_se (&se, NULL);
4847 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4848 gfc_add_block_to_block (pblock, &se.pre);
4849 gfc_add_modify (pblock, lbound, se.expr);
4851 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4852 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4854 gfc_init_se (&se, NULL);
4855 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4856 gfc_add_block_to_block (pblock, &se.pre);
4857 gfc_add_modify (pblock, ubound, se.expr);
4863 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4864 returns the size (in elements) of the array. */
4867 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4868 stmtblock_t * pblock)
4883 size = gfc_index_one_node;
4884 offset = gfc_index_zero_node;
4885 for (dim = 0; dim < as->rank; dim++)
4887 /* Evaluate non-constant array bound expressions. */
4888 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4889 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4891 gfc_init_se (&se, NULL);
4892 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4893 gfc_add_block_to_block (pblock, &se.pre);
4894 gfc_add_modify (pblock, lbound, se.expr);
4896 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4897 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4899 gfc_init_se (&se, NULL);
4900 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4901 gfc_add_block_to_block (pblock, &se.pre);
4902 gfc_add_modify (pblock, ubound, se.expr);
4904 /* The offset of this dimension. offset = offset - lbound * stride. */
4905 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4907 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4910 /* The size of this dimension, and the stride of the next. */
4911 if (dim + 1 < as->rank)
4912 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4914 stride = GFC_TYPE_ARRAY_SIZE (type);
4916 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4918 /* Calculate stride = size * (ubound + 1 - lbound). */
4919 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4920 gfc_array_index_type,
4921 gfc_index_one_node, lbound);
4922 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4923 gfc_array_index_type, ubound, tmp);
4924 tmp = fold_build2_loc (input_location, MULT_EXPR,
4925 gfc_array_index_type, size, tmp);
4927 gfc_add_modify (pblock, stride, tmp);
4929 stride = gfc_evaluate_now (tmp, pblock);
4931 /* Make sure that negative size arrays are translated
4932 to being zero size. */
4933 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4934 stride, gfc_index_zero_node);
4935 tmp = fold_build3_loc (input_location, COND_EXPR,
4936 gfc_array_index_type, tmp,
4937 stride, gfc_index_zero_node);
4938 gfc_add_modify (pblock, stride, tmp);
4944 gfc_trans_array_cobounds (type, pblock, sym);
4945 gfc_trans_vla_type_sizes (sym, pblock);
4952 /* Generate code to initialize/allocate an array variable. */
4955 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4956 gfc_wrapped_block * block)
4960 tree tmp = NULL_TREE;
4967 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
4969 /* Do nothing for USEd variables. */
4970 if (sym->attr.use_assoc)
4973 type = TREE_TYPE (decl);
4974 gcc_assert (GFC_ARRAY_TYPE_P (type));
4975 onstack = TREE_CODE (type) != POINTER_TYPE;
4977 gfc_init_block (&init);
4979 /* Evaluate character string length. */
4980 if (sym->ts.type == BT_CHARACTER
4981 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
4983 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4985 gfc_trans_vla_type_sizes (sym, &init);
4987 /* Emit a DECL_EXPR for this variable, which will cause the
4988 gimplifier to allocate storage, and all that good stuff. */
4989 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4990 gfc_add_expr_to_block (&init, tmp);
4995 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4999 type = TREE_TYPE (type);
5001 gcc_assert (!sym->attr.use_assoc);
5002 gcc_assert (!TREE_STATIC (decl));
5003 gcc_assert (!sym->module);
5005 if (sym->ts.type == BT_CHARACTER
5006 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5007 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5009 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5011 /* Don't actually allocate space for Cray Pointees. */
5012 if (sym->attr.cray_pointee)
5014 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5015 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5017 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5021 if (gfc_option.flag_stack_arrays)
5023 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5024 space = build_decl (sym->declared_at.lb->location,
5025 VAR_DECL, create_tmp_var_name ("A"),
5026 TREE_TYPE (TREE_TYPE (decl)));
5027 gfc_trans_vla_type_sizes (sym, &init);
5031 /* The size is the number of elements in the array, so multiply by the
5032 size of an element to get the total size. */
5033 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5034 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5035 size, fold_convert (gfc_array_index_type, tmp));
5037 /* Allocate memory to hold the data. */
5038 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5039 gfc_add_modify (&init, decl, tmp);
5041 /* Free the temporary. */
5042 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5046 /* Set offset of the array. */
5047 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5048 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5050 /* Automatic arrays should not have initializers. */
5051 gcc_assert (!sym->value);
5053 inittree = gfc_finish_block (&init);
5060 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5061 where also space is located. */
5062 gfc_init_block (&init);
5063 tmp = fold_build1_loc (input_location, DECL_EXPR,
5064 TREE_TYPE (space), space);
5065 gfc_add_expr_to_block (&init, tmp);
5066 addr = fold_build1_loc (sym->declared_at.lb->location,
5067 ADDR_EXPR, TREE_TYPE (decl), space);
5068 gfc_add_modify (&init, decl, addr);
5069 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5072 gfc_add_init_cleanup (block, inittree, tmp);
5076 /* Generate entry and exit code for g77 calling convention arrays. */
5079 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5089 gfc_save_backend_locus (&loc);
5090 gfc_set_backend_locus (&sym->declared_at);
5092 /* Descriptor type. */
5093 parm = sym->backend_decl;
5094 type = TREE_TYPE (parm);
5095 gcc_assert (GFC_ARRAY_TYPE_P (type));
5097 gfc_start_block (&init);
5099 if (sym->ts.type == BT_CHARACTER
5100 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5101 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5103 /* Evaluate the bounds of the array. */
5104 gfc_trans_array_bounds (type, sym, &offset, &init);
5106 /* Set the offset. */
5107 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5108 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5110 /* Set the pointer itself if we aren't using the parameter directly. */
5111 if (TREE_CODE (parm) != PARM_DECL)
5113 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5114 gfc_add_modify (&init, parm, tmp);
5116 stmt = gfc_finish_block (&init);
5118 gfc_restore_backend_locus (&loc);
5120 /* Add the initialization code to the start of the function. */
5122 if (sym->attr.optional || sym->attr.not_always_present)
5124 tmp = gfc_conv_expr_present (sym);
5125 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5128 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5132 /* Modify the descriptor of an array parameter so that it has the
5133 correct lower bound. Also move the upper bound accordingly.
5134 If the array is not packed, it will be copied into a temporary.
5135 For each dimension we set the new lower and upper bounds. Then we copy the
5136 stride and calculate the offset for this dimension. We also work out
5137 what the stride of a packed array would be, and see it the two match.
5138 If the array need repacking, we set the stride to the values we just
5139 calculated, recalculate the offset and copy the array data.
5140 Code is also added to copy the data back at the end of the function.
5144 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5145 gfc_wrapped_block * block)
5152 tree stmtInit, stmtCleanup;
5159 tree stride, stride2;
5169 /* Do nothing for pointer and allocatable arrays. */
5170 if (sym->attr.pointer || sym->attr.allocatable)
5173 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5175 gfc_trans_g77_array (sym, block);
5179 gfc_save_backend_locus (&loc);
5180 gfc_set_backend_locus (&sym->declared_at);
5182 /* Descriptor type. */
5183 type = TREE_TYPE (tmpdesc);
5184 gcc_assert (GFC_ARRAY_TYPE_P (type));
5185 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5186 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5187 gfc_start_block (&init);
5189 if (sym->ts.type == BT_CHARACTER
5190 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5191 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5193 checkparm = (sym->as->type == AS_EXPLICIT
5194 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5196 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5197 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5199 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5201 /* For non-constant shape arrays we only check if the first dimension
5202 is contiguous. Repacking higher dimensions wouldn't gain us
5203 anything as we still don't know the array stride. */
5204 partial = gfc_create_var (boolean_type_node, "partial");
5205 TREE_USED (partial) = 1;
5206 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5207 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5208 gfc_index_one_node);
5209 gfc_add_modify (&init, partial, tmp);
5212 partial = NULL_TREE;
5214 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5215 here, however I think it does the right thing. */
5218 /* Set the first stride. */
5219 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5220 stride = gfc_evaluate_now (stride, &init);
5222 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5223 stride, gfc_index_zero_node);
5224 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5225 tmp, gfc_index_one_node, stride);
5226 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5227 gfc_add_modify (&init, stride, tmp);
5229 /* Allow the user to disable array repacking. */
5230 stmt_unpacked = NULL_TREE;
5234 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5235 /* A library call to repack the array if necessary. */
5236 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5237 stmt_unpacked = build_call_expr_loc (input_location,
5238 gfor_fndecl_in_pack, 1, tmp);
5240 stride = gfc_index_one_node;
5242 if (gfc_option.warn_array_temp)
5243 gfc_warning ("Creating array temporary at %L", &loc);
5246 /* This is for the case where the array data is used directly without
5247 calling the repack function. */
5248 if (no_repack || partial != NULL_TREE)
5249 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5251 stmt_packed = NULL_TREE;
5253 /* Assign the data pointer. */
5254 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5256 /* Don't repack unknown shape arrays when the first stride is 1. */
5257 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5258 partial, stmt_packed, stmt_unpacked);
5261 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5262 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5264 offset = gfc_index_zero_node;
5265 size = gfc_index_one_node;
5267 /* Evaluate the bounds of the array. */
5268 for (n = 0; n < sym->as->rank; n++)
5270 if (checkparm || !sym->as->upper[n])
5272 /* Get the bounds of the actual parameter. */
5273 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5274 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5278 dubound = NULL_TREE;
5279 dlbound = NULL_TREE;
5282 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5283 if (!INTEGER_CST_P (lbound))
5285 gfc_init_se (&se, NULL);
5286 gfc_conv_expr_type (&se, sym->as->lower[n],
5287 gfc_array_index_type);
5288 gfc_add_block_to_block (&init, &se.pre);
5289 gfc_add_modify (&init, lbound, se.expr);
5292 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5293 /* Set the desired upper bound. */
5294 if (sym->as->upper[n])
5296 /* We know what we want the upper bound to be. */
5297 if (!INTEGER_CST_P (ubound))
5299 gfc_init_se (&se, NULL);
5300 gfc_conv_expr_type (&se, sym->as->upper[n],
5301 gfc_array_index_type);
5302 gfc_add_block_to_block (&init, &se.pre);
5303 gfc_add_modify (&init, ubound, se.expr);
5306 /* Check the sizes match. */
5309 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5313 temp = fold_build2_loc (input_location, MINUS_EXPR,
5314 gfc_array_index_type, ubound, lbound);
5315 temp = fold_build2_loc (input_location, PLUS_EXPR,
5316 gfc_array_index_type,
5317 gfc_index_one_node, temp);
5318 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5319 gfc_array_index_type, dubound,
5321 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5322 gfc_array_index_type,
5323 gfc_index_one_node, stride2);
5324 tmp = fold_build2_loc (input_location, NE_EXPR,
5325 gfc_array_index_type, temp, stride2);
5326 asprintf (&msg, "Dimension %d of array '%s' has extent "
5327 "%%ld instead of %%ld", n+1, sym->name);
5329 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5330 fold_convert (long_integer_type_node, temp),
5331 fold_convert (long_integer_type_node, stride2));
5338 /* For assumed shape arrays move the upper bound by the same amount
5339 as the lower bound. */
5340 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5341 gfc_array_index_type, dubound, dlbound);
5342 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5343 gfc_array_index_type, tmp, lbound);
5344 gfc_add_modify (&init, ubound, tmp);
5346 /* The offset of this dimension. offset = offset - lbound * stride. */
5347 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5349 offset = fold_build2_loc (input_location, MINUS_EXPR,
5350 gfc_array_index_type, offset, tmp);
5352 /* The size of this dimension, and the stride of the next. */
5353 if (n + 1 < sym->as->rank)
5355 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5357 if (no_repack || partial != NULL_TREE)
5359 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5361 /* Figure out the stride if not a known constant. */
5362 if (!INTEGER_CST_P (stride))
5365 stmt_packed = NULL_TREE;
5368 /* Calculate stride = size * (ubound + 1 - lbound). */
5369 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5370 gfc_array_index_type,
5371 gfc_index_one_node, lbound);
5372 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5373 gfc_array_index_type, ubound, tmp);
5374 size = fold_build2_loc (input_location, MULT_EXPR,
5375 gfc_array_index_type, size, tmp);
5379 /* Assign the stride. */
5380 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5381 tmp = fold_build3_loc (input_location, COND_EXPR,
5382 gfc_array_index_type, partial,
5383 stmt_unpacked, stmt_packed);
5385 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5386 gfc_add_modify (&init, stride, tmp);
5391 stride = GFC_TYPE_ARRAY_SIZE (type);
5393 if (stride && !INTEGER_CST_P (stride))
5395 /* Calculate size = stride * (ubound + 1 - lbound). */
5396 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5397 gfc_array_index_type,
5398 gfc_index_one_node, lbound);
5399 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5400 gfc_array_index_type,
5402 tmp = fold_build2_loc (input_location, MULT_EXPR,
5403 gfc_array_index_type,
5404 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5405 gfc_add_modify (&init, stride, tmp);
5410 gfc_trans_array_cobounds (type, &init, sym);
5412 /* Set the offset. */
5413 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5414 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5416 gfc_trans_vla_type_sizes (sym, &init);
5418 stmtInit = gfc_finish_block (&init);
5420 /* Only do the entry/initialization code if the arg is present. */
5421 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5422 optional_arg = (sym->attr.optional
5423 || (sym->ns->proc_name->attr.entry_master
5424 && sym->attr.dummy));
5427 tmp = gfc_conv_expr_present (sym);
5428 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5429 build_empty_stmt (input_location));
5434 stmtCleanup = NULL_TREE;
5437 stmtblock_t cleanup;
5438 gfc_start_block (&cleanup);
5440 if (sym->attr.intent != INTENT_IN)
5442 /* Copy the data back. */
5443 tmp = build_call_expr_loc (input_location,
5444 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5445 gfc_add_expr_to_block (&cleanup, tmp);
5448 /* Free the temporary. */
5449 tmp = gfc_call_free (tmpdesc);
5450 gfc_add_expr_to_block (&cleanup, tmp);
5452 stmtCleanup = gfc_finish_block (&cleanup);
5454 /* Only do the cleanup if the array was repacked. */
5455 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5456 tmp = gfc_conv_descriptor_data_get (tmp);
5457 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5459 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5460 build_empty_stmt (input_location));
5464 tmp = gfc_conv_expr_present (sym);
5465 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5466 build_empty_stmt (input_location));
5470 /* We don't need to free any memory allocated by internal_pack as it will
5471 be freed at the end of the function by pop_context. */
5472 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5474 gfc_restore_backend_locus (&loc);
5478 /* Calculate the overall offset, including subreferences. */
5480 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5481 bool subref, gfc_expr *expr)
5491 /* If offset is NULL and this is not a subreferenced array, there is
5493 if (offset == NULL_TREE)
5496 offset = gfc_index_zero_node;
5501 tmp = gfc_conv_array_data (desc);
5502 tmp = build_fold_indirect_ref_loc (input_location,
5504 tmp = gfc_build_array_ref (tmp, offset, NULL);
5506 /* Offset the data pointer for pointer assignments from arrays with
5507 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5510 /* Go past the array reference. */
5511 for (ref = expr->ref; ref; ref = ref->next)
5512 if (ref->type == REF_ARRAY &&
5513 ref->u.ar.type != AR_ELEMENT)
5519 /* Calculate the offset for each subsequent subreference. */
5520 for (; ref; ref = ref->next)
5525 field = ref->u.c.component->backend_decl;
5526 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5527 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5529 tmp, field, NULL_TREE);
5533 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5534 gfc_init_se (&start, NULL);
5535 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5536 gfc_add_block_to_block (block, &start.pre);
5537 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5541 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5542 && ref->u.ar.type == AR_ELEMENT);
5544 /* TODO - Add bounds checking. */
5545 stride = gfc_index_one_node;
5546 index = gfc_index_zero_node;
5547 for (n = 0; n < ref->u.ar.dimen; n++)
5552 /* Update the index. */
5553 gfc_init_se (&start, NULL);
5554 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5555 itmp = gfc_evaluate_now (start.expr, block);
5556 gfc_init_se (&start, NULL);
5557 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5558 jtmp = gfc_evaluate_now (start.expr, block);
5559 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5560 gfc_array_index_type, itmp, jtmp);
5561 itmp = fold_build2_loc (input_location, MULT_EXPR,
5562 gfc_array_index_type, itmp, stride);
5563 index = fold_build2_loc (input_location, PLUS_EXPR,
5564 gfc_array_index_type, itmp, index);
5565 index = gfc_evaluate_now (index, block);
5567 /* Update the stride. */
5568 gfc_init_se (&start, NULL);
5569 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5570 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5571 gfc_array_index_type, start.expr,
5573 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5574 gfc_array_index_type,
5575 gfc_index_one_node, itmp);
5576 stride = fold_build2_loc (input_location, MULT_EXPR,
5577 gfc_array_index_type, stride, itmp);
5578 stride = gfc_evaluate_now (stride, block);
5581 /* Apply the index to obtain the array element. */
5582 tmp = gfc_build_array_ref (tmp, index, NULL);
5592 /* Set the target data pointer. */
5593 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5594 gfc_conv_descriptor_data_set (block, parm, offset);
5598 /* gfc_conv_expr_descriptor needs the string length an expression
5599 so that the size of the temporary can be obtained. This is done
5600 by adding up the string lengths of all the elements in the
5601 expression. Function with non-constant expressions have their
5602 string lengths mapped onto the actual arguments using the
5603 interface mapping machinery in trans-expr.c. */
5605 get_array_charlen (gfc_expr *expr, gfc_se *se)
5607 gfc_interface_mapping mapping;
5608 gfc_formal_arglist *formal;
5609 gfc_actual_arglist *arg;
5612 if (expr->ts.u.cl->length
5613 && gfc_is_constant_expr (expr->ts.u.cl->length))
5615 if (!expr->ts.u.cl->backend_decl)
5616 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5620 switch (expr->expr_type)
5623 get_array_charlen (expr->value.op.op1, se);
5625 /* For parentheses the expression ts.u.cl is identical. */
5626 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5629 expr->ts.u.cl->backend_decl =
5630 gfc_create_var (gfc_charlen_type_node, "sln");
5632 if (expr->value.op.op2)
5634 get_array_charlen (expr->value.op.op2, se);
5636 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5638 /* Add the string lengths and assign them to the expression
5639 string length backend declaration. */
5640 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5641 fold_build2_loc (input_location, PLUS_EXPR,
5642 gfc_charlen_type_node,
5643 expr->value.op.op1->ts.u.cl->backend_decl,
5644 expr->value.op.op2->ts.u.cl->backend_decl));
5647 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5648 expr->value.op.op1->ts.u.cl->backend_decl);
5652 if (expr->value.function.esym == NULL
5653 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5655 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5659 /* Map expressions involving the dummy arguments onto the actual
5660 argument expressions. */
5661 gfc_init_interface_mapping (&mapping);
5662 formal = expr->symtree->n.sym->formal;
5663 arg = expr->value.function.actual;
5665 /* Set se = NULL in the calls to the interface mapping, to suppress any
5667 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5672 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5675 gfc_init_se (&tse, NULL);
5677 /* Build the expression for the character length and convert it. */
5678 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5680 gfc_add_block_to_block (&se->pre, &tse.pre);
5681 gfc_add_block_to_block (&se->post, &tse.post);
5682 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5683 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5684 gfc_charlen_type_node, tse.expr,
5685 build_int_cst (gfc_charlen_type_node, 0));
5686 expr->ts.u.cl->backend_decl = tse.expr;
5687 gfc_free_interface_mapping (&mapping);
5691 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5697 /* Helper function to check dimensions. */
5699 transposed_dims (gfc_ss *ss)
5703 for (n = 0; n < ss->dimen; n++)
5704 if (ss->dim[n] != n)
5709 /* Convert an array for passing as an actual argument. Expressions and
5710 vector subscripts are evaluated and stored in a temporary, which is then
5711 passed. For whole arrays the descriptor is passed. For array sections
5712 a modified copy of the descriptor is passed, but using the original data.
5714 This function is also used for array pointer assignments, and there
5717 - se->want_pointer && !se->direct_byref
5718 EXPR is an actual argument. On exit, se->expr contains a
5719 pointer to the array descriptor.
5721 - !se->want_pointer && !se->direct_byref
5722 EXPR is an actual argument to an intrinsic function or the
5723 left-hand side of a pointer assignment. On exit, se->expr
5724 contains the descriptor for EXPR.
5726 - !se->want_pointer && se->direct_byref
5727 EXPR is the right-hand side of a pointer assignment and
5728 se->expr is the descriptor for the previously-evaluated
5729 left-hand side. The function creates an assignment from
5733 The se->force_tmp flag disables the non-copying descriptor optimization
5734 that is used for transpose. It may be used in cases where there is an
5735 alias between the transpose argument and another argument in the same
5739 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5741 gfc_ss_type ss_type;
5743 gfc_array_info *info;
5752 bool subref_array_target = false;
5755 gcc_assert (ss != NULL);
5756 gcc_assert (ss != gfc_ss_terminator);
5758 ss_type = ss->info->type;
5760 /* Special case things we know we can pass easily. */
5761 switch (expr->expr_type)
5764 /* If we have a linear array section, we can pass it directly.
5765 Otherwise we need to copy it into a temporary. */
5767 gcc_assert (ss_type == GFC_SS_SECTION);
5768 gcc_assert (ss->expr == expr);
5769 info = &ss->data.info;
5771 /* Get the descriptor for the array. */
5772 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5773 desc = info->descriptor;
5775 subref_array_target = se->direct_byref && is_subref_array (expr);
5776 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5777 && !subref_array_target;
5784 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5786 /* Create a new descriptor if the array doesn't have one. */
5789 else if (info->ref->u.ar.type == AR_FULL)
5791 else if (se->direct_byref)
5794 full = gfc_full_array_ref_p (info->ref, NULL);
5796 if (full && !transposed_dims (ss))
5798 if (se->direct_byref && !se->byref_noassign)
5800 /* Copy the descriptor for pointer assignments. */
5801 gfc_add_modify (&se->pre, se->expr, desc);
5803 /* Add any offsets from subreferences. */
5804 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5805 subref_array_target, expr);
5807 else if (se->want_pointer)
5809 /* We pass full arrays directly. This means that pointers and
5810 allocatable arrays should also work. */
5811 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5818 if (expr->ts.type == BT_CHARACTER)
5819 se->string_length = gfc_get_expr_charlen (expr);
5827 /* We don't need to copy data in some cases. */
5828 arg = gfc_get_noncopying_intrinsic_argument (expr);
5831 /* This is a call to transpose... */
5832 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5833 /* ... which has already been handled by the scalarizer, so
5834 that we just need to get its argument's descriptor. */
5835 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5839 /* A transformational function return value will be a temporary
5840 array descriptor. We still need to go through the scalarizer
5841 to create the descriptor. Elemental functions ar handled as
5842 arbitrary expressions, i.e. copy to a temporary. */
5844 if (se->direct_byref)
5846 gcc_assert (ss_type == GFC_SS_FUNCTION && ss->expr == expr);
5848 /* For pointer assignments pass the descriptor directly. */
5852 gcc_assert (se->ss == ss);
5853 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5854 gfc_conv_expr (se, expr);
5858 if (ss->expr != expr || ss_type != GFC_SS_FUNCTION)
5860 if (ss->expr != expr)
5861 /* Elemental function. */
5862 gcc_assert ((expr->value.function.esym != NULL
5863 && expr->value.function.esym->attr.elemental)
5864 || (expr->value.function.isym != NULL
5865 && expr->value.function.isym->elemental));
5867 gcc_assert (ss_type == GFC_SS_INTRINSIC);
5870 if (expr->ts.type == BT_CHARACTER
5871 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5872 get_array_charlen (expr, se);
5878 /* Transformational function. */
5879 info = &ss->data.info;
5885 /* Constant array constructors don't need a temporary. */
5886 if (ss_type == GFC_SS_CONSTRUCTOR
5887 && expr->ts.type != BT_CHARACTER
5888 && gfc_constant_array_constructor_p (expr->value.constructor))
5891 info = &ss->data.info;
5901 /* Something complicated. Copy it into a temporary. */
5907 /* If we are creating a temporary, we don't need to bother about aliases
5912 gfc_init_loopinfo (&loop);
5914 /* Associate the SS with the loop. */
5915 gfc_add_ss_to_loop (&loop, ss);
5917 /* Tell the scalarizer not to bother creating loop variables, etc. */
5919 loop.array_parameter = 1;
5921 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5922 gcc_assert (!se->direct_byref);
5924 /* Setup the scalarizing loops and bounds. */
5925 gfc_conv_ss_startstride (&loop);
5929 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5930 get_array_charlen (expr, se);
5932 /* Tell the scalarizer to make a temporary. */
5933 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
5934 ((expr->ts.type == BT_CHARACTER)
5935 ? expr->ts.u.cl->backend_decl
5939 se->string_length = loop.temp_ss->string_length;
5940 gcc_assert (loop.temp_ss->dimen == loop.dimen);
5941 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5944 gfc_conv_loop_setup (&loop, & expr->where);
5948 /* Copy into a temporary and pass that. We don't need to copy the data
5949 back because expressions and vector subscripts must be INTENT_IN. */
5950 /* TODO: Optimize passing function return values. */
5954 /* Start the copying loops. */
5955 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5956 gfc_mark_ss_chain_used (ss, 1);
5957 gfc_start_scalarized_body (&loop, &block);
5959 /* Copy each data element. */
5960 gfc_init_se (&lse, NULL);
5961 gfc_copy_loopinfo_to_se (&lse, &loop);
5962 gfc_init_se (&rse, NULL);
5963 gfc_copy_loopinfo_to_se (&rse, &loop);
5965 lse.ss = loop.temp_ss;
5968 gfc_conv_scalarized_array_ref (&lse, NULL);
5969 if (expr->ts.type == BT_CHARACTER)
5971 gfc_conv_expr (&rse, expr);
5972 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
5973 rse.expr = build_fold_indirect_ref_loc (input_location,
5977 gfc_conv_expr_val (&rse, expr);
5979 gfc_add_block_to_block (&block, &rse.pre);
5980 gfc_add_block_to_block (&block, &lse.pre);
5982 lse.string_length = rse.string_length;
5983 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
5984 expr->expr_type == EXPR_VARIABLE
5985 || expr->expr_type == EXPR_ARRAY, true);
5986 gfc_add_expr_to_block (&block, tmp);
5988 /* Finish the copying loops. */
5989 gfc_trans_scalarizing_loops (&loop, &block);
5991 desc = loop.temp_ss->data.info.descriptor;
5993 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
5995 desc = info->descriptor;
5996 se->string_length = ss->string_length;
6000 /* We pass sections without copying to a temporary. Make a new
6001 descriptor and point it at the section we want. The loop variable
6002 limits will be the limits of the section.
6003 A function may decide to repack the array to speed up access, but
6004 we're not bothered about that here. */
6005 int dim, ndim, codim;
6013 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6015 if (se->want_coarray)
6017 gfc_array_ref *ar = &info->ref->u.ar;
6019 codim = gfc_get_corank (expr);
6020 for (n = 0; n < codim - 1; n++)
6022 /* Make sure we are not lost somehow. */
6023 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6025 /* Make sure the call to gfc_conv_section_startstride won't
6026 generate unnecessary code to calculate stride. */
6027 gcc_assert (ar->stride[n + ndim] == NULL);
6029 gfc_conv_section_startstride (&loop, ss, n + ndim);
6030 loop.from[n + loop.dimen] = info->start[n + ndim];
6031 loop.to[n + loop.dimen] = info->end[n + ndim];
6034 gcc_assert (n == codim - 1);
6035 evaluate_bound (&loop.pre, info->start, ar->start,
6036 info->descriptor, n + ndim, true);
6037 loop.from[n + loop.dimen] = info->start[n + ndim];
6042 /* Set the string_length for a character array. */
6043 if (expr->ts.type == BT_CHARACTER)
6044 se->string_length = gfc_get_expr_charlen (expr);
6046 desc = info->descriptor;
6047 if (se->direct_byref && !se->byref_noassign)
6049 /* For pointer assignments we fill in the destination. */
6051 parmtype = TREE_TYPE (parm);
6055 /* Otherwise make a new one. */
6056 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6057 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6058 loop.from, loop.to, 0,
6059 GFC_ARRAY_UNKNOWN, false);
6060 parm = gfc_create_var (parmtype, "parm");
6063 offset = gfc_index_zero_node;
6065 /* The following can be somewhat confusing. We have two
6066 descriptors, a new one and the original array.
6067 {parm, parmtype, dim} refer to the new one.
6068 {desc, type, n, loop} refer to the original, which maybe
6069 a descriptorless array.
6070 The bounds of the scalarization are the bounds of the section.
6071 We don't have to worry about numeric overflows when calculating
6072 the offsets because all elements are within the array data. */
6074 /* Set the dtype. */
6075 tmp = gfc_conv_descriptor_dtype (parm);
6076 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6078 /* Set offset for assignments to pointer only to zero if it is not
6080 if (se->direct_byref
6081 && info->ref && info->ref->u.ar.type != AR_FULL)
6082 base = gfc_index_zero_node;
6083 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6084 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6088 for (n = 0; n < ndim; n++)
6090 stride = gfc_conv_array_stride (desc, n);
6092 /* Work out the offset. */
6094 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6096 gcc_assert (info->subscript[n]
6097 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6098 start = info->subscript[n]->data.scalar.expr;
6102 /* Evaluate and remember the start of the section. */
6103 start = info->start[n];
6104 stride = gfc_evaluate_now (stride, &loop.pre);
6107 tmp = gfc_conv_array_lbound (desc, n);
6108 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6110 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6112 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6116 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6118 /* For elemental dimensions, we only need the offset. */
6122 /* Vector subscripts need copying and are handled elsewhere. */
6124 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6126 /* look for the corresponding scalarizer dimension: dim. */
6127 for (dim = 0; dim < ndim; dim++)
6128 if (ss->dim[dim] == n)
6131 /* loop exited early: the DIM being looked for has been found. */
6132 gcc_assert (dim < ndim);
6134 /* Set the new lower bound. */
6135 from = loop.from[dim];
6138 /* If we have an array section or are assigning make sure that
6139 the lower bound is 1. References to the full
6140 array should otherwise keep the original bounds. */
6142 || info->ref->u.ar.type != AR_FULL)
6143 && !integer_onep (from))
6145 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6146 gfc_array_index_type, gfc_index_one_node,
6148 to = fold_build2_loc (input_location, PLUS_EXPR,
6149 gfc_array_index_type, to, tmp);
6150 from = gfc_index_one_node;
6152 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6153 gfc_rank_cst[dim], from);
6155 /* Set the new upper bound. */
6156 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6157 gfc_rank_cst[dim], to);
6159 /* Multiply the stride by the section stride to get the
6161 stride = fold_build2_loc (input_location, MULT_EXPR,
6162 gfc_array_index_type,
6163 stride, info->stride[n]);
6165 if (se->direct_byref
6167 && info->ref->u.ar.type != AR_FULL)
6169 base = fold_build2_loc (input_location, MINUS_EXPR,
6170 TREE_TYPE (base), base, stride);
6172 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6174 tmp = gfc_conv_array_lbound (desc, n);
6175 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6176 TREE_TYPE (base), tmp, loop.from[dim]);
6177 tmp = fold_build2_loc (input_location, MULT_EXPR,
6178 TREE_TYPE (base), tmp,
6179 gfc_conv_array_stride (desc, n));
6180 base = fold_build2_loc (input_location, PLUS_EXPR,
6181 TREE_TYPE (base), tmp, base);
6184 /* Store the new stride. */
6185 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6186 gfc_rank_cst[dim], stride);
6189 for (n = loop.dimen; n < loop.dimen + codim; n++)
6191 from = loop.from[n];
6193 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6194 gfc_rank_cst[n], from);
6195 if (n < loop.dimen + codim - 1)
6196 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6197 gfc_rank_cst[n], to);
6200 if (se->data_not_needed)
6201 gfc_conv_descriptor_data_set (&loop.pre, parm,
6202 gfc_index_zero_node);
6204 /* Point the data pointer at the 1st element in the section. */
6205 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6206 subref_array_target, expr);
6208 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6209 && !se->data_not_needed)
6211 /* Set the offset. */
6212 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6216 /* Only the callee knows what the correct offset it, so just set
6218 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6223 if (!se->direct_byref || se->byref_noassign)
6225 /* Get a pointer to the new descriptor. */
6226 if (se->want_pointer)
6227 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6232 gfc_add_block_to_block (&se->pre, &loop.pre);
6233 gfc_add_block_to_block (&se->post, &loop.post);
6235 /* Cleanup the scalarizer. */
6236 gfc_cleanup_loop (&loop);
6239 /* Helper function for gfc_conv_array_parameter if array size needs to be
6243 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6246 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6247 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6248 else if (expr->rank > 1)
6249 *size = build_call_expr_loc (input_location,
6250 gfor_fndecl_size0, 1,
6251 gfc_build_addr_expr (NULL, desc));
6254 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6255 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6257 *size = fold_build2_loc (input_location, MINUS_EXPR,
6258 gfc_array_index_type, ubound, lbound);
6259 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6260 *size, gfc_index_one_node);
6261 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6262 *size, gfc_index_zero_node);
6264 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6265 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6266 *size, fold_convert (gfc_array_index_type, elem));
6269 /* Convert an array for passing as an actual parameter. */
6270 /* TODO: Optimize passing g77 arrays. */
6273 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6274 const gfc_symbol *fsym, const char *proc_name,
6279 tree tmp = NULL_TREE;
6281 tree parent = DECL_CONTEXT (current_function_decl);
6282 bool full_array_var;
6283 bool this_array_result;
6286 bool array_constructor;
6287 bool good_allocatable;
6288 bool ultimate_ptr_comp;
6289 bool ultimate_alloc_comp;
6294 ultimate_ptr_comp = false;
6295 ultimate_alloc_comp = false;
6297 for (ref = expr->ref; ref; ref = ref->next)
6299 if (ref->next == NULL)
6302 if (ref->type == REF_COMPONENT)
6304 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6305 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6309 full_array_var = false;
6312 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6313 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6315 sym = full_array_var ? expr->symtree->n.sym : NULL;
6317 /* The symbol should have an array specification. */
6318 gcc_assert (!sym || sym->as || ref->u.ar.as);
6320 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6322 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6323 expr->ts.u.cl->backend_decl = tmp;
6324 se->string_length = tmp;
6327 /* Is this the result of the enclosing procedure? */
6328 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6329 if (this_array_result
6330 && (sym->backend_decl != current_function_decl)
6331 && (sym->backend_decl != parent))
6332 this_array_result = false;
6334 /* Passing address of the array if it is not pointer or assumed-shape. */
6335 if (full_array_var && g77 && !this_array_result)
6337 tmp = gfc_get_symbol_decl (sym);
6339 if (sym->ts.type == BT_CHARACTER)
6340 se->string_length = sym->ts.u.cl->backend_decl;
6342 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6344 gfc_conv_expr_descriptor (se, expr, ss);
6345 se->expr = gfc_conv_array_data (se->expr);
6349 if (!sym->attr.pointer
6351 && sym->as->type != AS_ASSUMED_SHAPE
6352 && !sym->attr.allocatable)
6354 /* Some variables are declared directly, others are declared as
6355 pointers and allocated on the heap. */
6356 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6359 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6361 array_parameter_size (tmp, expr, size);
6365 if (sym->attr.allocatable)
6367 if (sym->attr.dummy || sym->attr.result)
6369 gfc_conv_expr_descriptor (se, expr, ss);
6373 array_parameter_size (tmp, expr, size);
6374 se->expr = gfc_conv_array_data (tmp);
6379 /* A convenient reduction in scope. */
6380 contiguous = g77 && !this_array_result && contiguous;
6382 /* There is no need to pack and unpack the array, if it is contiguous
6383 and not a deferred- or assumed-shape array, or if it is simply
6385 no_pack = ((sym && sym->as
6386 && !sym->attr.pointer
6387 && sym->as->type != AS_DEFERRED
6388 && sym->as->type != AS_ASSUMED_SHAPE)
6390 (ref && ref->u.ar.as
6391 && ref->u.ar.as->type != AS_DEFERRED
6392 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6394 gfc_is_simply_contiguous (expr, false));
6396 no_pack = contiguous && no_pack;
6398 /* Array constructors are always contiguous and do not need packing. */
6399 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6401 /* Same is true of contiguous sections from allocatable variables. */
6402 good_allocatable = contiguous
6404 && expr->symtree->n.sym->attr.allocatable;
6406 /* Or ultimate allocatable components. */
6407 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6409 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6411 gfc_conv_expr_descriptor (se, expr, ss);
6412 if (expr->ts.type == BT_CHARACTER)
6413 se->string_length = expr->ts.u.cl->backend_decl;
6415 array_parameter_size (se->expr, expr, size);
6416 se->expr = gfc_conv_array_data (se->expr);
6420 if (this_array_result)
6422 /* Result of the enclosing function. */
6423 gfc_conv_expr_descriptor (se, expr, ss);
6425 array_parameter_size (se->expr, expr, size);
6426 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6428 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6429 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6430 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6437 /* Every other type of array. */
6438 se->want_pointer = 1;
6439 gfc_conv_expr_descriptor (se, expr, ss);
6441 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6446 /* Deallocate the allocatable components of structures that are
6448 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6449 && expr->ts.u.derived->attr.alloc_comp
6450 && expr->expr_type != EXPR_VARIABLE)
6452 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6453 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6455 /* The components shall be deallocated before their containing entity. */
6456 gfc_prepend_expr_to_block (&se->post, tmp);
6459 if (g77 || (fsym && fsym->attr.contiguous
6460 && !gfc_is_simply_contiguous (expr, false)))
6462 tree origptr = NULL_TREE;
6466 /* For contiguous arrays, save the original value of the descriptor. */
6469 origptr = gfc_create_var (pvoid_type_node, "origptr");
6470 tmp = build_fold_indirect_ref_loc (input_location, desc);
6471 tmp = gfc_conv_array_data (tmp);
6472 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6473 TREE_TYPE (origptr), origptr,
6474 fold_convert (TREE_TYPE (origptr), tmp));
6475 gfc_add_expr_to_block (&se->pre, tmp);
6478 /* Repack the array. */
6479 if (gfc_option.warn_array_temp)
6482 gfc_warning ("Creating array temporary at %L for argument '%s'",
6483 &expr->where, fsym->name);
6485 gfc_warning ("Creating array temporary at %L", &expr->where);
6488 ptr = build_call_expr_loc (input_location,
6489 gfor_fndecl_in_pack, 1, desc);
6491 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6493 tmp = gfc_conv_expr_present (sym);
6494 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6495 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6496 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6499 ptr = gfc_evaluate_now (ptr, &se->pre);
6501 /* Use the packed data for the actual argument, except for contiguous arrays,
6502 where the descriptor's data component is set. */
6507 tmp = build_fold_indirect_ref_loc (input_location, desc);
6508 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6511 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6515 if (fsym && proc_name)
6516 asprintf (&msg, "An array temporary was created for argument "
6517 "'%s' of procedure '%s'", fsym->name, proc_name);
6519 asprintf (&msg, "An array temporary was created");
6521 tmp = build_fold_indirect_ref_loc (input_location,
6523 tmp = gfc_conv_array_data (tmp);
6524 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6525 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6527 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6528 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6530 gfc_conv_expr_present (sym), tmp);
6532 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6537 gfc_start_block (&block);
6539 /* Copy the data back. */
6540 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6542 tmp = build_call_expr_loc (input_location,
6543 gfor_fndecl_in_unpack, 2, desc, ptr);
6544 gfc_add_expr_to_block (&block, tmp);
6547 /* Free the temporary. */
6548 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6549 gfc_add_expr_to_block (&block, tmp);
6551 stmt = gfc_finish_block (&block);
6553 gfc_init_block (&block);
6554 /* Only if it was repacked. This code needs to be executed before the
6555 loop cleanup code. */
6556 tmp = build_fold_indirect_ref_loc (input_location,
6558 tmp = gfc_conv_array_data (tmp);
6559 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6560 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6562 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6563 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6565 gfc_conv_expr_present (sym), tmp);
6567 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6569 gfc_add_expr_to_block (&block, tmp);
6570 gfc_add_block_to_block (&block, &se->post);
6572 gfc_init_block (&se->post);
6574 /* Reset the descriptor pointer. */
6577 tmp = build_fold_indirect_ref_loc (input_location, desc);
6578 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6581 gfc_add_block_to_block (&se->post, &block);
6586 /* Generate code to deallocate an array, if it is allocated. */
6589 gfc_trans_dealloc_allocated (tree descriptor)
6595 gfc_start_block (&block);
6597 var = gfc_conv_descriptor_data_get (descriptor);
6600 /* Call array_deallocate with an int * present in the second argument.
6601 Although it is ignored here, it's presence ensures that arrays that
6602 are already deallocated are ignored. */
6603 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6604 gfc_add_expr_to_block (&block, tmp);
6606 /* Zero the data pointer. */
6607 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6608 var, build_int_cst (TREE_TYPE (var), 0));
6609 gfc_add_expr_to_block (&block, tmp);
6611 return gfc_finish_block (&block);
6615 /* This helper function calculates the size in words of a full array. */
6618 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6623 idx = gfc_rank_cst[rank - 1];
6624 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6625 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6626 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6628 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6629 tmp, gfc_index_one_node);
6630 tmp = gfc_evaluate_now (tmp, block);
6632 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6633 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6635 return gfc_evaluate_now (tmp, block);
6639 /* Allocate dest to the same size as src, and copy src -> dest.
6640 If no_malloc is set, only the copy is done. */
6643 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6653 /* If the source is null, set the destination to null. Then,
6654 allocate memory to the destination. */
6655 gfc_init_block (&block);
6659 tmp = null_pointer_node;
6660 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6661 gfc_add_expr_to_block (&block, tmp);
6662 null_data = gfc_finish_block (&block);
6664 gfc_init_block (&block);
6665 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6668 tmp = gfc_call_malloc (&block, type, size);
6669 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6670 dest, fold_convert (type, tmp));
6671 gfc_add_expr_to_block (&block, tmp);
6674 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6675 tmp = build_call_expr_loc (input_location, tmp, 3,
6680 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6681 null_data = gfc_finish_block (&block);
6683 gfc_init_block (&block);
6684 nelems = get_full_array_size (&block, src, rank);
6685 tmp = fold_convert (gfc_array_index_type,
6686 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6687 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6691 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6692 tmp = gfc_call_malloc (&block, tmp, size);
6693 gfc_conv_descriptor_data_set (&block, dest, tmp);
6696 /* We know the temporary and the value will be the same length,
6697 so can use memcpy. */
6698 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6699 tmp = build_call_expr_loc (input_location,
6700 tmp, 3, gfc_conv_descriptor_data_get (dest),
6701 gfc_conv_descriptor_data_get (src), size);
6704 gfc_add_expr_to_block (&block, tmp);
6705 tmp = gfc_finish_block (&block);
6707 /* Null the destination if the source is null; otherwise do
6708 the allocate and copy. */
6712 null_cond = gfc_conv_descriptor_data_get (src);
6714 null_cond = convert (pvoid_type_node, null_cond);
6715 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6716 null_cond, null_pointer_node);
6717 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6721 /* Allocate dest to the same size as src, and copy data src -> dest. */
6724 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6726 return duplicate_allocatable (dest, src, type, rank, false);
6730 /* Copy data src -> dest. */
6733 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6735 return duplicate_allocatable (dest, src, type, rank, true);
6739 /* Recursively traverse an object of derived type, generating code to
6740 deallocate, nullify or copy allocatable components. This is the work horse
6741 function for the functions named in this enum. */
6743 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6744 COPY_ONLY_ALLOC_COMP};
6747 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6748 tree dest, int rank, int purpose)
6752 stmtblock_t fnblock;
6753 stmtblock_t loopbody;
6764 tree null_cond = NULL_TREE;
6766 gfc_init_block (&fnblock);
6768 decl_type = TREE_TYPE (decl);
6770 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6771 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6773 decl = build_fold_indirect_ref_loc (input_location,
6776 /* Just in case in gets dereferenced. */
6777 decl_type = TREE_TYPE (decl);
6779 /* If this an array of derived types with allocatable components
6780 build a loop and recursively call this function. */
6781 if (TREE_CODE (decl_type) == ARRAY_TYPE
6782 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6784 tmp = gfc_conv_array_data (decl);
6785 var = build_fold_indirect_ref_loc (input_location,
6788 /* Get the number of elements - 1 and set the counter. */
6789 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6791 /* Use the descriptor for an allocatable array. Since this
6792 is a full array reference, we only need the descriptor
6793 information from dimension = rank. */
6794 tmp = get_full_array_size (&fnblock, decl, rank);
6795 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6796 gfc_array_index_type, tmp,
6797 gfc_index_one_node);
6799 null_cond = gfc_conv_descriptor_data_get (decl);
6800 null_cond = fold_build2_loc (input_location, NE_EXPR,
6801 boolean_type_node, null_cond,
6802 build_int_cst (TREE_TYPE (null_cond), 0));
6806 /* Otherwise use the TYPE_DOMAIN information. */
6807 tmp = array_type_nelts (decl_type);
6808 tmp = fold_convert (gfc_array_index_type, tmp);
6811 /* Remember that this is, in fact, the no. of elements - 1. */
6812 nelems = gfc_evaluate_now (tmp, &fnblock);
6813 index = gfc_create_var (gfc_array_index_type, "S");
6815 /* Build the body of the loop. */
6816 gfc_init_block (&loopbody);
6818 vref = gfc_build_array_ref (var, index, NULL);
6820 if (purpose == COPY_ALLOC_COMP)
6822 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6824 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6825 gfc_add_expr_to_block (&fnblock, tmp);
6827 tmp = build_fold_indirect_ref_loc (input_location,
6828 gfc_conv_array_data (dest));
6829 dref = gfc_build_array_ref (tmp, index, NULL);
6830 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6832 else if (purpose == COPY_ONLY_ALLOC_COMP)
6834 tmp = build_fold_indirect_ref_loc (input_location,
6835 gfc_conv_array_data (dest));
6836 dref = gfc_build_array_ref (tmp, index, NULL);
6837 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6841 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6843 gfc_add_expr_to_block (&loopbody, tmp);
6845 /* Build the loop and return. */
6846 gfc_init_loopinfo (&loop);
6848 loop.from[0] = gfc_index_zero_node;
6849 loop.loopvar[0] = index;
6850 loop.to[0] = nelems;
6851 gfc_trans_scalarizing_loops (&loop, &loopbody);
6852 gfc_add_block_to_block (&fnblock, &loop.pre);
6854 tmp = gfc_finish_block (&fnblock);
6855 if (null_cond != NULL_TREE)
6856 tmp = build3_v (COND_EXPR, null_cond, tmp,
6857 build_empty_stmt (input_location));
6862 /* Otherwise, act on the components or recursively call self to
6863 act on a chain of components. */
6864 for (c = der_type->components; c; c = c->next)
6866 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6867 || c->ts.type == BT_CLASS)
6868 && c->ts.u.derived->attr.alloc_comp;
6869 cdecl = c->backend_decl;
6870 ctype = TREE_TYPE (cdecl);
6874 case DEALLOCATE_ALLOC_COMP:
6875 if (cmp_has_alloc_comps && !c->attr.pointer)
6877 /* Do not deallocate the components of ultimate pointer
6879 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6880 decl, cdecl, NULL_TREE);
6881 rank = c->as ? c->as->rank : 0;
6882 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6884 gfc_add_expr_to_block (&fnblock, tmp);
6887 if (c->attr.allocatable
6888 && (c->attr.dimension || c->attr.codimension))
6890 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6891 decl, cdecl, NULL_TREE);
6892 tmp = gfc_trans_dealloc_allocated (comp);
6893 gfc_add_expr_to_block (&fnblock, tmp);
6895 else if (c->attr.allocatable)
6897 /* Allocatable scalar components. */
6898 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6899 decl, cdecl, NULL_TREE);
6901 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6903 gfc_add_expr_to_block (&fnblock, tmp);
6905 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6906 void_type_node, comp,
6907 build_int_cst (TREE_TYPE (comp), 0));
6908 gfc_add_expr_to_block (&fnblock, tmp);
6910 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6912 /* Allocatable scalar CLASS components. */
6913 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6914 decl, cdecl, NULL_TREE);
6916 /* Add reference to '_data' component. */
6917 tmp = CLASS_DATA (c)->backend_decl;
6918 comp = fold_build3_loc (input_location, COMPONENT_REF,
6919 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6921 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6922 CLASS_DATA (c)->ts);
6923 gfc_add_expr_to_block (&fnblock, tmp);
6925 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6926 void_type_node, comp,
6927 build_int_cst (TREE_TYPE (comp), 0));
6928 gfc_add_expr_to_block (&fnblock, tmp);
6932 case NULLIFY_ALLOC_COMP:
6933 if (c->attr.pointer)
6935 else if (c->attr.allocatable
6936 && (c->attr.dimension|| c->attr.codimension))
6938 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6939 decl, cdecl, NULL_TREE);
6940 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6942 else if (c->attr.allocatable)
6944 /* Allocatable scalar components. */
6945 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6946 decl, cdecl, NULL_TREE);
6947 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6948 void_type_node, comp,
6949 build_int_cst (TREE_TYPE (comp), 0));
6950 gfc_add_expr_to_block (&fnblock, tmp);
6952 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6954 /* Allocatable scalar CLASS components. */
6955 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6956 decl, cdecl, NULL_TREE);
6957 /* Add reference to '_data' component. */
6958 tmp = CLASS_DATA (c)->backend_decl;
6959 comp = fold_build3_loc (input_location, COMPONENT_REF,
6960 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6961 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6962 void_type_node, comp,
6963 build_int_cst (TREE_TYPE (comp), 0));
6964 gfc_add_expr_to_block (&fnblock, tmp);
6966 else if (cmp_has_alloc_comps)
6968 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6969 decl, cdecl, NULL_TREE);
6970 rank = c->as ? c->as->rank : 0;
6971 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6973 gfc_add_expr_to_block (&fnblock, tmp);
6977 case COPY_ALLOC_COMP:
6978 if (c->attr.pointer)
6981 /* We need source and destination components. */
6982 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
6984 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
6986 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
6988 if (c->attr.allocatable && !cmp_has_alloc_comps)
6990 rank = c->as ? c->as->rank : 0;
6991 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
6992 gfc_add_expr_to_block (&fnblock, tmp);
6995 if (cmp_has_alloc_comps)
6997 rank = c->as ? c->as->rank : 0;
6998 tmp = fold_convert (TREE_TYPE (dcmp), comp);
6999 gfc_add_modify (&fnblock, dcmp, tmp);
7000 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7002 gfc_add_expr_to_block (&fnblock, tmp);
7012 return gfc_finish_block (&fnblock);
7015 /* Recursively traverse an object of derived type, generating code to
7016 nullify allocatable components. */
7019 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7021 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7022 NULLIFY_ALLOC_COMP);
7026 /* Recursively traverse an object of derived type, generating code to
7027 deallocate allocatable components. */
7030 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7032 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7033 DEALLOCATE_ALLOC_COMP);
7037 /* Recursively traverse an object of derived type, generating code to
7038 copy it and its allocatable components. */
7041 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7043 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7047 /* Recursively traverse an object of derived type, generating code to
7048 copy only its allocatable components. */
7051 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7053 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7057 /* Returns the value of LBOUND for an expression. This could be broken out
7058 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7059 called by gfc_alloc_allocatable_for_assignment. */
7061 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7066 tree cond, cond1, cond3, cond4;
7070 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7072 tmp = gfc_rank_cst[dim];
7073 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7074 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7075 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7076 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7078 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7079 stride, gfc_index_zero_node);
7080 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7081 boolean_type_node, cond3, cond1);
7082 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7083 stride, gfc_index_zero_node);
7085 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7086 tmp, build_int_cst (gfc_array_index_type,
7089 cond = boolean_false_node;
7091 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7092 boolean_type_node, cond3, cond4);
7093 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7094 boolean_type_node, cond, cond1);
7096 return fold_build3_loc (input_location, COND_EXPR,
7097 gfc_array_index_type, cond,
7098 lbound, gfc_index_one_node);
7100 else if (expr->expr_type == EXPR_VARIABLE)
7102 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7103 for (ref = expr->ref; ref; ref = ref->next)
7105 if (ref->type == REF_COMPONENT
7106 && ref->u.c.component->as
7108 && ref->next->u.ar.type == AR_FULL)
7109 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7111 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7113 else if (expr->expr_type == EXPR_FUNCTION)
7115 /* A conversion function, so use the argument. */
7116 expr = expr->value.function.actual->expr;
7117 if (expr->expr_type != EXPR_VARIABLE)
7118 return gfc_index_one_node;
7119 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7120 return get_std_lbound (expr, desc, dim, assumed_size);
7123 return gfc_index_one_node;
7127 /* Returns true if an expression represents an lhs that can be reallocated
7131 gfc_is_reallocatable_lhs (gfc_expr *expr)
7138 /* An allocatable variable. */
7139 if (expr->symtree->n.sym->attr.allocatable
7141 && expr->ref->type == REF_ARRAY
7142 && expr->ref->u.ar.type == AR_FULL)
7145 /* All that can be left are allocatable components. */
7146 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7147 && expr->symtree->n.sym->ts.type != BT_CLASS)
7148 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7151 /* Find a component ref followed by an array reference. */
7152 for (ref = expr->ref; ref; ref = ref->next)
7154 && ref->type == REF_COMPONENT
7155 && ref->next->type == REF_ARRAY
7156 && !ref->next->next)
7162 /* Return true if valid reallocatable lhs. */
7163 if (ref->u.c.component->attr.allocatable
7164 && ref->next->u.ar.type == AR_FULL)
7171 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7175 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7179 stmtblock_t realloc_block;
7180 stmtblock_t alloc_block;
7203 gfc_array_spec * as;
7205 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7206 Find the lhs expression in the loop chain and set expr1 and
7207 expr2 accordingly. */
7208 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7211 /* Find the ss for the lhs. */
7213 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7214 if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
7216 if (lss == gfc_ss_terminator)
7221 /* Bail out if this is not a valid allocate on assignment. */
7222 if (!gfc_is_reallocatable_lhs (expr1)
7223 || (expr2 && !expr2->rank))
7226 /* Find the ss for the lhs. */
7228 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7229 if (lss->expr == expr1)
7232 if (lss == gfc_ss_terminator)
7235 /* Find an ss for the rhs. For operator expressions, we see the
7236 ss's for the operands. Any one of these will do. */
7238 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7239 if (rss->expr != expr1 && rss != loop->temp_ss)
7242 if (expr2 && rss == gfc_ss_terminator)
7245 gfc_start_block (&fblock);
7247 /* Since the lhs is allocatable, this must be a descriptor type.
7248 Get the data and array size. */
7249 desc = lss->data.info.descriptor;
7250 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7251 array1 = gfc_conv_descriptor_data_get (desc);
7253 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7254 deallocated if expr is an array of different shape or any of the
7255 corresponding length type parameter values of variable and expr
7256 differ." This assures F95 compatibility. */
7257 jump_label1 = gfc_build_label_decl (NULL_TREE);
7258 jump_label2 = gfc_build_label_decl (NULL_TREE);
7260 /* Allocate if data is NULL. */
7261 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7262 array1, build_int_cst (TREE_TYPE (array1), 0));
7263 tmp = build3_v (COND_EXPR, cond,
7264 build1_v (GOTO_EXPR, jump_label1),
7265 build_empty_stmt (input_location));
7266 gfc_add_expr_to_block (&fblock, tmp);
7268 /* Get arrayspec if expr is a full array. */
7269 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7270 && expr2->value.function.isym
7271 && expr2->value.function.isym->conversion)
7273 /* For conversion functions, take the arg. */
7274 gfc_expr *arg = expr2->value.function.actual->expr;
7275 as = gfc_get_full_arrayspec_from_expr (arg);
7278 as = gfc_get_full_arrayspec_from_expr (expr2);
7282 /* If the lhs shape is not the same as the rhs jump to setting the
7283 bounds and doing the reallocation....... */
7284 for (n = 0; n < expr1->rank; n++)
7286 /* Check the shape. */
7287 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7288 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7289 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7290 gfc_array_index_type,
7291 loop->to[n], loop->from[n]);
7292 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7293 gfc_array_index_type,
7295 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7296 gfc_array_index_type,
7298 cond = fold_build2_loc (input_location, NE_EXPR,
7300 tmp, gfc_index_zero_node);
7301 tmp = build3_v (COND_EXPR, cond,
7302 build1_v (GOTO_EXPR, jump_label1),
7303 build_empty_stmt (input_location));
7304 gfc_add_expr_to_block (&fblock, tmp);
7307 /* ....else jump past the (re)alloc code. */
7308 tmp = build1_v (GOTO_EXPR, jump_label2);
7309 gfc_add_expr_to_block (&fblock, tmp);
7311 /* Add the label to start automatic (re)allocation. */
7312 tmp = build1_v (LABEL_EXPR, jump_label1);
7313 gfc_add_expr_to_block (&fblock, tmp);
7315 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7317 /* Get the rhs size. Fix both sizes. */
7319 desc2 = rss->data.info.descriptor;
7322 size2 = gfc_index_one_node;
7323 for (n = 0; n < expr2->rank; n++)
7325 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7326 gfc_array_index_type,
7327 loop->to[n], loop->from[n]);
7328 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7329 gfc_array_index_type,
7330 tmp, gfc_index_one_node);
7331 size2 = fold_build2_loc (input_location, MULT_EXPR,
7332 gfc_array_index_type,
7336 size1 = gfc_evaluate_now (size1, &fblock);
7337 size2 = gfc_evaluate_now (size2, &fblock);
7339 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7341 neq_size = gfc_evaluate_now (cond, &fblock);
7344 /* Now modify the lhs descriptor and the associated scalarizer
7345 variables. F2003 7.4.1.3: "If variable is or becomes an
7346 unallocated allocatable variable, then it is allocated with each
7347 deferred type parameter equal to the corresponding type parameters
7348 of expr , with the shape of expr , and with each lower bound equal
7349 to the corresponding element of LBOUND(expr)."
7350 Reuse size1 to keep a dimension-by-dimension track of the
7351 stride of the new array. */
7352 size1 = gfc_index_one_node;
7353 offset = gfc_index_zero_node;
7355 for (n = 0; n < expr2->rank; n++)
7357 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7358 gfc_array_index_type,
7359 loop->to[n], loop->from[n]);
7360 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7361 gfc_array_index_type,
7362 tmp, gfc_index_one_node);
7364 lbound = gfc_index_one_node;
7369 lbd = get_std_lbound (expr2, desc2, n,
7370 as->type == AS_ASSUMED_SIZE);
7371 ubound = fold_build2_loc (input_location,
7373 gfc_array_index_type,
7375 ubound = fold_build2_loc (input_location,
7377 gfc_array_index_type,
7382 gfc_conv_descriptor_lbound_set (&fblock, desc,
7385 gfc_conv_descriptor_ubound_set (&fblock, desc,
7388 gfc_conv_descriptor_stride_set (&fblock, desc,
7391 lbound = gfc_conv_descriptor_lbound_get (desc,
7393 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7394 gfc_array_index_type,
7396 offset = fold_build2_loc (input_location, MINUS_EXPR,
7397 gfc_array_index_type,
7399 size1 = fold_build2_loc (input_location, MULT_EXPR,
7400 gfc_array_index_type,
7404 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7405 the array offset is saved and the info.offset is used for a
7406 running offset. Use the saved_offset instead. */
7407 tmp = gfc_conv_descriptor_offset (desc);
7408 gfc_add_modify (&fblock, tmp, offset);
7409 if (lss->data.info.saved_offset
7410 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7411 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7413 /* Now set the deltas for the lhs. */
7414 for (n = 0; n < expr1->rank; n++)
7416 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7418 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7419 gfc_array_index_type, tmp,
7421 if (lss->data.info.delta[dim]
7422 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7423 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7426 /* Get the new lhs size in bytes. */
7427 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7429 tmp = expr2->ts.u.cl->backend_decl;
7430 gcc_assert (expr1->ts.u.cl->backend_decl);
7431 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7432 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7434 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7436 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7437 tmp = fold_build2_loc (input_location, MULT_EXPR,
7438 gfc_array_index_type, tmp,
7439 expr1->ts.u.cl->backend_decl);
7442 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7443 tmp = fold_convert (gfc_array_index_type, tmp);
7444 size2 = fold_build2_loc (input_location, MULT_EXPR,
7445 gfc_array_index_type,
7447 size2 = fold_convert (size_type_node, size2);
7448 size2 = gfc_evaluate_now (size2, &fblock);
7450 /* Realloc expression. Note that the scalarizer uses desc.data
7451 in the array reference - (*desc.data)[<element>]. */
7452 gfc_init_block (&realloc_block);
7453 tmp = build_call_expr_loc (input_location,
7454 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
7455 fold_convert (pvoid_type_node, array1),
7457 gfc_conv_descriptor_data_set (&realloc_block,
7459 realloc_expr = gfc_finish_block (&realloc_block);
7461 /* Only reallocate if sizes are different. */
7462 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7463 build_empty_stmt (input_location));
7467 /* Malloc expression. */
7468 gfc_init_block (&alloc_block);
7469 tmp = build_call_expr_loc (input_location,
7470 builtin_decl_explicit (BUILT_IN_MALLOC),
7472 gfc_conv_descriptor_data_set (&alloc_block,
7474 tmp = gfc_conv_descriptor_dtype (desc);
7475 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7476 alloc_expr = gfc_finish_block (&alloc_block);
7478 /* Malloc if not allocated; realloc otherwise. */
7479 tmp = build_int_cst (TREE_TYPE (array1), 0);
7480 cond = fold_build2_loc (input_location, EQ_EXPR,
7483 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7484 gfc_add_expr_to_block (&fblock, tmp);
7486 /* Make sure that the scalarizer data pointer is updated. */
7487 if (lss->data.info.data
7488 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7490 tmp = gfc_conv_descriptor_data_get (desc);
7491 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7494 /* Add the exit label. */
7495 tmp = build1_v (LABEL_EXPR, jump_label2);
7496 gfc_add_expr_to_block (&fblock, tmp);
7498 return gfc_finish_block (&fblock);
7502 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7503 Do likewise, recursively if necessary, with the allocatable components of
7507 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7513 stmtblock_t cleanup;
7516 bool sym_has_alloc_comp;
7518 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7519 || sym->ts.type == BT_CLASS)
7520 && sym->ts.u.derived->attr.alloc_comp;
7522 /* Make sure the frontend gets these right. */
7523 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7524 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7525 "allocatable attribute or derived type without allocatable "
7528 gfc_save_backend_locus (&loc);
7529 gfc_set_backend_locus (&sym->declared_at);
7530 gfc_init_block (&init);
7532 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7533 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7535 if (sym->ts.type == BT_CHARACTER
7536 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7538 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7539 gfc_trans_vla_type_sizes (sym, &init);
7542 /* Dummy, use associated and result variables don't need anything special. */
7543 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7545 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7546 gfc_restore_backend_locus (&loc);
7550 descriptor = sym->backend_decl;
7552 /* Although static, derived types with default initializers and
7553 allocatable components must not be nulled wholesale; instead they
7554 are treated component by component. */
7555 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7557 /* SAVEd variables are not freed on exit. */
7558 gfc_trans_static_array_pointer (sym);
7560 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7561 gfc_restore_backend_locus (&loc);
7565 /* Get the descriptor type. */
7566 type = TREE_TYPE (sym->backend_decl);
7568 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7571 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7573 if (sym->value == NULL
7574 || !gfc_has_default_initializer (sym->ts.u.derived))
7576 rank = sym->as ? sym->as->rank : 0;
7577 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7579 gfc_add_expr_to_block (&init, tmp);
7582 gfc_init_default_dt (sym, &init, false);
7585 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7587 /* If the backend_decl is not a descriptor, we must have a pointer
7589 descriptor = build_fold_indirect_ref_loc (input_location,
7591 type = TREE_TYPE (descriptor);
7594 /* NULLIFY the data pointer. */
7595 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7596 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7598 gfc_restore_backend_locus (&loc);
7599 gfc_init_block (&cleanup);
7601 /* Allocatable arrays need to be freed when they go out of scope.
7602 The allocatable components of pointers must not be touched. */
7603 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7604 && !sym->attr.pointer && !sym->attr.save)
7607 rank = sym->as ? sym->as->rank : 0;
7608 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7609 gfc_add_expr_to_block (&cleanup, tmp);
7612 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7613 && !sym->attr.save && !sym->attr.result)
7615 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7616 gfc_add_expr_to_block (&cleanup, tmp);
7619 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7620 gfc_finish_block (&cleanup));
7623 /************ Expression Walking Functions ******************/
7625 /* Walk a variable reference.
7627 Possible extension - multiple component subscripts.
7628 x(:,:) = foo%a(:)%b(:)
7630 forall (i=..., j=...)
7631 x(i,j) = foo%a(j)%b(i)
7633 This adds a fair amount of complexity because you need to deal with more
7634 than one ref. Maybe handle in a similar manner to vector subscripts.
7635 Maybe not worth the effort. */
7639 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7643 for (ref = expr->ref; ref; ref = ref->next)
7644 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7647 return gfc_walk_array_ref (ss, expr, ref);
7652 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
7658 for (; ref; ref = ref->next)
7660 if (ref->type == REF_SUBSTRING)
7662 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
7663 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
7666 /* We're only interested in array sections from now on. */
7667 if (ref->type != REF_ARRAY)
7675 for (n = ar->dimen - 1; n >= 0; n--)
7676 ss = gfc_get_scalar_ss (ss, ar->start[n]);
7680 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
7681 newss->data.info.ref = ref;
7683 /* Make sure array is the same as array(:,:), this way
7684 we don't need to special case all the time. */
7685 ar->dimen = ar->as->rank;
7686 for (n = 0; n < ar->dimen; n++)
7688 ar->dimen_type[n] = DIMEN_RANGE;
7690 gcc_assert (ar->start[n] == NULL);
7691 gcc_assert (ar->end[n] == NULL);
7692 gcc_assert (ar->stride[n] == NULL);
7698 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
7699 newss->data.info.ref = ref;
7701 /* We add SS chains for all the subscripts in the section. */
7702 for (n = 0; n < ar->dimen; n++)
7706 switch (ar->dimen_type[n])
7709 /* Add SS for elemental (scalar) subscripts. */
7710 gcc_assert (ar->start[n]);
7711 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
7712 indexss->loop_chain = gfc_ss_terminator;
7713 newss->data.info.subscript[n] = indexss;
7717 /* We don't add anything for sections, just remember this
7718 dimension for later. */
7719 newss->dim[newss->dimen] = n;
7724 /* Create a GFC_SS_VECTOR index in which we can store
7725 the vector's descriptor. */
7726 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
7728 indexss->loop_chain = gfc_ss_terminator;
7729 newss->data.info.subscript[n] = indexss;
7730 newss->dim[newss->dimen] = n;
7735 /* We should know what sort of section it is by now. */
7739 /* We should have at least one non-elemental dimension,
7740 unless we are creating a descriptor for a (scalar) coarray. */
7741 gcc_assert (newss->dimen > 0
7742 || newss->data.info.ref->u.ar.as->corank > 0);
7747 /* We should know what sort of section it is by now. */
7756 /* Walk an expression operator. If only one operand of a binary expression is
7757 scalar, we must also add the scalar term to the SS chain. */
7760 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7765 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7766 if (expr->value.op.op2 == NULL)
7769 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7771 /* All operands are scalar. Pass back and let the caller deal with it. */
7775 /* All operands require scalarization. */
7776 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7779 /* One of the operands needs scalarization, the other is scalar.
7780 Create a gfc_ss for the scalar expression. */
7783 /* First operand is scalar. We build the chain in reverse order, so
7784 add the scalar SS after the second operand. */
7786 while (head && head->next != ss)
7788 /* Check we haven't somehow broken the chain. */
7790 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
7792 else /* head2 == head */
7794 gcc_assert (head2 == head);
7795 /* Second operand is scalar. */
7796 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
7803 /* Reverse a SS chain. */
7806 gfc_reverse_ss (gfc_ss * ss)
7811 gcc_assert (ss != NULL);
7813 head = gfc_ss_terminator;
7814 while (ss != gfc_ss_terminator)
7817 /* Check we didn't somehow break the chain. */
7818 gcc_assert (next != NULL);
7828 /* Walk the arguments of an elemental function. */
7831 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7839 head = gfc_ss_terminator;
7842 for (; arg; arg = arg->next)
7847 newss = gfc_walk_subexpr (head, arg->expr);
7850 /* Scalar argument. */
7851 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
7852 newss = gfc_get_scalar_ss (head, arg->expr);
7853 newss->info->type = type;
7862 while (tail->next != gfc_ss_terminator)
7869 /* If all the arguments are scalar we don't need the argument SS. */
7870 gfc_free_ss_chain (head);
7875 /* Add it onto the existing chain. */
7881 /* Walk a function call. Scalar functions are passed back, and taken out of
7882 scalarization loops. For elemental functions we walk their arguments.
7883 The result of functions returning arrays is stored in a temporary outside
7884 the loop, so that the function is only called once. Hence we do not need
7885 to walk their arguments. */
7888 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7890 gfc_intrinsic_sym *isym;
7892 gfc_component *comp = NULL;
7894 isym = expr->value.function.isym;
7896 /* Handle intrinsic functions separately. */
7898 return gfc_walk_intrinsic_function (ss, expr, isym);
7900 sym = expr->value.function.esym;
7902 sym = expr->symtree->n.sym;
7904 /* A function that returns arrays. */
7905 gfc_is_proc_ptr_comp (expr, &comp);
7906 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7907 || (comp && comp->attr.dimension))
7908 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
7910 /* Walk the parameters of an elemental function. For now we always pass
7912 if (sym->attr.elemental)
7913 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7916 /* Scalar functions are OK as these are evaluated outside the scalarization
7917 loop. Pass back and let the caller deal with it. */
7922 /* An array temporary is constructed for array constructors. */
7925 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7927 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
7931 /* Walk an expression. Add walked expressions to the head of the SS chain.
7932 A wholly scalar expression will not be added. */
7935 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7939 switch (expr->expr_type)
7942 head = gfc_walk_variable_expr (ss, expr);
7946 head = gfc_walk_op_expr (ss, expr);
7950 head = gfc_walk_function_expr (ss, expr);
7955 case EXPR_STRUCTURE:
7956 /* Pass back and let the caller deal with it. */
7960 head = gfc_walk_array_constructor (ss, expr);
7963 case EXPR_SUBSTRING:
7964 /* Pass back and let the caller deal with it. */
7968 internal_error ("bad expression type during walk (%d)",
7975 /* Entry point for expression walking.
7976 A return value equal to the passed chain means this is
7977 a scalar expression. It is up to the caller to take whatever action is
7978 necessary to translate these. */
7981 gfc_walk_expr (gfc_expr * expr)
7985 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
7986 return gfc_reverse_ss (res);