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;
536 ss_info->expr = expr;
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;
560 ss_info->string_length = string_length;
564 ss->next = gfc_ss_terminator;
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;
584 ss_info->expr = expr;
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->info->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;
1956 gfc_ss_info *ss_info;
1959 /* Save the old values for nested checking. */
1960 old_first_len = first_len;
1961 old_first_len_val = first_len_val;
1962 old_typespec_chararray_ctor = typespec_chararray_ctor;
1965 expr = ss_info->expr;
1967 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1968 typespec was given for the array constructor. */
1969 typespec_chararray_ctor = (expr->ts.u.cl
1970 && expr->ts.u.cl->length_from_typespec);
1972 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1973 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1975 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1979 gcc_assert (ss->dimen == loop->dimen);
1981 c = expr->value.constructor;
1982 if (expr->ts.type == BT_CHARACTER)
1986 /* get_array_ctor_strlen walks the elements of the constructor, if a
1987 typespec was given, we already know the string length and want the one
1989 if (typespec_chararray_ctor && expr->ts.u.cl->length
1990 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1994 const_string = false;
1995 gfc_init_se (&length_se, NULL);
1996 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
1997 gfc_charlen_type_node);
1998 ss_info->string_length = length_se.expr;
1999 gfc_add_block_to_block (&loop->pre, &length_se.pre);
2000 gfc_add_block_to_block (&loop->post, &length_se.post);
2003 const_string = get_array_ctor_strlen (&loop->pre, c,
2004 &ss_info->string_length);
2006 /* Complex character array constructors should have been taken care of
2007 and not end up here. */
2008 gcc_assert (ss_info->string_length);
2010 expr->ts.u.cl->backend_decl = ss_info->string_length;
2012 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2014 type = build_pointer_type (type);
2017 type = gfc_typenode_for_spec (&expr->ts);
2019 /* See if the constructor determines the loop bounds. */
2022 if (expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
2024 /* We have a multidimensional parameter. */
2026 for (n = 0; n < expr->rank; n++)
2028 loop->from[n] = gfc_index_zero_node;
2029 loop->to[n] = gfc_conv_mpz_to_tree (expr->shape [n],
2030 gfc_index_integer_kind);
2031 loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2032 gfc_array_index_type,
2033 loop->to[n], gfc_index_one_node);
2037 if (loop->to[0] == NULL_TREE)
2041 /* We should have a 1-dimensional, zero-based loop. */
2042 gcc_assert (loop->dimen == 1);
2043 gcc_assert (integer_zerop (loop->from[0]));
2045 /* Split the constructor size into a static part and a dynamic part.
2046 Allocate the static size up-front and record whether the dynamic
2047 size might be nonzero. */
2049 dynamic = gfc_get_array_constructor_size (&size, c);
2050 mpz_sub_ui (size, size, 1);
2051 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2055 /* Special case constant array constructors. */
2058 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2061 tree size = constant_array_constructor_loop_size (loop);
2062 if (size && compare_tree_int (size, nelem) == 0)
2064 trans_constant_array_constructor (ss, type);
2070 if (TREE_CODE (loop->to[0]) == VAR_DECL)
2073 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, ss,
2074 type, NULL_TREE, dynamic, true, false, where);
2076 desc = ss->data.info.descriptor;
2077 offset = gfc_index_zero_node;
2078 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2079 TREE_NO_WARNING (offsetvar) = 1;
2080 TREE_USED (offsetvar) = 0;
2081 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2082 &offset, &offsetvar, dynamic);
2084 /* If the array grows dynamically, the upper bound of the loop variable
2085 is determined by the array's final upper bound. */
2088 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2089 gfc_array_index_type,
2090 offsetvar, gfc_index_one_node);
2091 tmp = gfc_evaluate_now (tmp, &loop->pre);
2092 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2093 if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
2094 gfc_add_modify (&loop->pre, loop->to[0], tmp);
2099 if (TREE_USED (offsetvar))
2100 pushdecl (offsetvar);
2102 gcc_assert (INTEGER_CST_P (offset));
2105 /* Disable bound checking for now because it's probably broken. */
2106 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2113 /* Restore old values of globals. */
2114 first_len = old_first_len;
2115 first_len_val = old_first_len_val;
2116 typespec_chararray_ctor = old_typespec_chararray_ctor;
2120 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2121 called after evaluating all of INFO's vector dimensions. Go through
2122 each such vector dimension and see if we can now fill in any missing
2126 set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss)
2128 gfc_array_info *info;
2136 info = &ss->data.info;
2138 for (n = 0; n < loop->dimen; n++)
2141 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
2142 && loop->to[n] == NULL)
2144 /* Loop variable N indexes vector dimension DIM, and we don't
2145 yet know the upper bound of loop variable N. Set it to the
2146 difference between the vector's upper and lower bounds. */
2147 gcc_assert (loop->from[n] == gfc_index_zero_node);
2148 gcc_assert (info->subscript[dim]
2149 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2151 gfc_init_se (&se, NULL);
2152 desc = info->subscript[dim]->data.info.descriptor;
2153 zero = gfc_rank_cst[0];
2154 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2155 gfc_array_index_type,
2156 gfc_conv_descriptor_ubound_get (desc, zero),
2157 gfc_conv_descriptor_lbound_get (desc, zero));
2158 tmp = gfc_evaluate_now (tmp, &loop->pre);
2165 /* Add the pre and post chains for all the scalar expressions in a SS chain
2166 to loop. This is called after the loop parameters have been calculated,
2167 but before the actual scalarizing loops. */
2170 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2174 gfc_ss_info *ss_info;
2178 /* TODO: This can generate bad code if there are ordering dependencies,
2179 e.g., a callee allocated function and an unknown size constructor. */
2180 gcc_assert (ss != NULL);
2182 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2187 expr = ss_info->expr;
2189 switch (ss_info->type)
2192 /* Scalar expression. Evaluate this now. This includes elemental
2193 dimension indices, but not array section bounds. */
2194 gfc_init_se (&se, NULL);
2195 gfc_conv_expr (&se, expr);
2196 gfc_add_block_to_block (&loop->pre, &se.pre);
2198 if (expr->ts.type != BT_CHARACTER)
2200 /* Move the evaluation of scalar expressions outside the
2201 scalarization loop, except for WHERE assignments. */
2203 se.expr = convert(gfc_array_index_type, se.expr);
2205 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2206 gfc_add_block_to_block (&loop->pre, &se.post);
2209 gfc_add_block_to_block (&loop->post, &se.post);
2211 ss->data.scalar.expr = se.expr;
2212 ss_info->string_length = se.string_length;
2215 case GFC_SS_REFERENCE:
2216 /* Scalar argument to elemental procedure. Evaluate this
2218 gfc_init_se (&se, NULL);
2219 gfc_conv_expr (&se, expr);
2220 gfc_add_block_to_block (&loop->pre, &se.pre);
2221 gfc_add_block_to_block (&loop->post, &se.post);
2223 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2224 ss_info->string_length = se.string_length;
2227 case GFC_SS_SECTION:
2228 /* Add the expressions for scalar and vector subscripts. */
2229 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2230 if (ss->data.info.subscript[n])
2231 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2234 set_vector_loop_bounds (loop, ss);
2238 /* Get the vector's descriptor and store it in SS. */
2239 gfc_init_se (&se, NULL);
2240 gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2241 gfc_add_block_to_block (&loop->pre, &se.pre);
2242 gfc_add_block_to_block (&loop->post, &se.post);
2243 ss->data.info.descriptor = se.expr;
2246 case GFC_SS_INTRINSIC:
2247 gfc_add_intrinsic_ss_code (loop, ss);
2250 case GFC_SS_FUNCTION:
2251 /* Array function return value. We call the function and save its
2252 result in a temporary for use inside the loop. */
2253 gfc_init_se (&se, NULL);
2256 gfc_conv_expr (&se, expr);
2257 gfc_add_block_to_block (&loop->pre, &se.pre);
2258 gfc_add_block_to_block (&loop->post, &se.post);
2259 ss_info->string_length = se.string_length;
2262 case GFC_SS_CONSTRUCTOR:
2263 if (expr->ts.type == BT_CHARACTER
2264 && ss_info->string_length == NULL
2266 && expr->ts.u.cl->length)
2268 gfc_init_se (&se, NULL);
2269 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2270 gfc_charlen_type_node);
2271 ss_info->string_length = se.expr;
2272 gfc_add_block_to_block (&loop->pre, &se.pre);
2273 gfc_add_block_to_block (&loop->post, &se.post);
2275 gfc_trans_array_constructor (loop, ss, where);
2279 case GFC_SS_COMPONENT:
2280 /* Do nothing. These are handled elsewhere. */
2290 /* Translate expressions for the descriptor and data pointer of a SS. */
2294 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2297 gfc_ss_info *ss_info;
2302 /* Get the descriptor for the array to be scalarized. */
2303 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2304 gfc_init_se (&se, NULL);
2305 se.descriptor_only = 1;
2306 gfc_conv_expr_lhs (&se, ss_info->expr);
2307 gfc_add_block_to_block (block, &se.pre);
2308 ss->data.info.descriptor = se.expr;
2309 ss_info->string_length = se.string_length;
2313 /* Also the data pointer. */
2314 tmp = gfc_conv_array_data (se.expr);
2315 /* If this is a variable or address of a variable we use it directly.
2316 Otherwise we must evaluate it now to avoid breaking dependency
2317 analysis by pulling the expressions for elemental array indices
2320 || (TREE_CODE (tmp) == ADDR_EXPR
2321 && DECL_P (TREE_OPERAND (tmp, 0)))))
2322 tmp = gfc_evaluate_now (tmp, block);
2323 ss->data.info.data = tmp;
2325 tmp = gfc_conv_array_offset (se.expr);
2326 ss->data.info.offset = gfc_evaluate_now (tmp, block);
2328 /* Make absolutely sure that the saved_offset is indeed saved
2329 so that the variable is still accessible after the loops
2331 ss->data.info.saved_offset = ss->data.info.offset;
2336 /* Initialize a gfc_loopinfo structure. */
2339 gfc_init_loopinfo (gfc_loopinfo * loop)
2343 memset (loop, 0, sizeof (gfc_loopinfo));
2344 gfc_init_block (&loop->pre);
2345 gfc_init_block (&loop->post);
2347 /* Initially scalarize in order and default to no loop reversal. */
2348 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2351 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2354 loop->ss = gfc_ss_terminator;
2358 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2362 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2368 /* Return an expression for the data pointer of an array. */
2371 gfc_conv_array_data (tree descriptor)
2375 type = TREE_TYPE (descriptor);
2376 if (GFC_ARRAY_TYPE_P (type))
2378 if (TREE_CODE (type) == POINTER_TYPE)
2382 /* Descriptorless arrays. */
2383 return gfc_build_addr_expr (NULL_TREE, descriptor);
2387 return gfc_conv_descriptor_data_get (descriptor);
2391 /* Return an expression for the base offset of an array. */
2394 gfc_conv_array_offset (tree descriptor)
2398 type = TREE_TYPE (descriptor);
2399 if (GFC_ARRAY_TYPE_P (type))
2400 return GFC_TYPE_ARRAY_OFFSET (type);
2402 return gfc_conv_descriptor_offset_get (descriptor);
2406 /* Get an expression for the array stride. */
2409 gfc_conv_array_stride (tree descriptor, int dim)
2414 type = TREE_TYPE (descriptor);
2416 /* For descriptorless arrays use the array size. */
2417 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2418 if (tmp != NULL_TREE)
2421 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2426 /* Like gfc_conv_array_stride, but for the lower bound. */
2429 gfc_conv_array_lbound (tree descriptor, int dim)
2434 type = TREE_TYPE (descriptor);
2436 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2437 if (tmp != NULL_TREE)
2440 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2445 /* Like gfc_conv_array_stride, but for the upper bound. */
2448 gfc_conv_array_ubound (tree descriptor, int dim)
2453 type = TREE_TYPE (descriptor);
2455 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2456 if (tmp != NULL_TREE)
2459 /* This should only ever happen when passing an assumed shape array
2460 as an actual parameter. The value will never be used. */
2461 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2462 return gfc_index_zero_node;
2464 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2469 /* Generate code to perform an array index bound check. */
2472 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2473 locus * where, bool check_upper)
2476 tree tmp_lo, tmp_up;
2479 const char * name = NULL;
2481 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2484 descriptor = ss->data.info.descriptor;
2486 index = gfc_evaluate_now (index, &se->pre);
2488 /* We find a name for the error message. */
2489 name = ss->info->expr->symtree->n.sym->name;
2490 gcc_assert (name != NULL);
2492 if (TREE_CODE (descriptor) == VAR_DECL)
2493 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2495 /* If upper bound is present, include both bounds in the error message. */
2498 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2499 tmp_up = gfc_conv_array_ubound (descriptor, n);
2502 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2503 "outside of expected range (%%ld:%%ld)", n+1, name);
2505 asprintf (&msg, "Index '%%ld' of dimension %d "
2506 "outside of expected range (%%ld:%%ld)", n+1);
2508 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2510 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2511 fold_convert (long_integer_type_node, index),
2512 fold_convert (long_integer_type_node, tmp_lo),
2513 fold_convert (long_integer_type_node, tmp_up));
2514 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2516 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2517 fold_convert (long_integer_type_node, index),
2518 fold_convert (long_integer_type_node, tmp_lo),
2519 fold_convert (long_integer_type_node, tmp_up));
2524 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2527 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2528 "below lower bound of %%ld", n+1, name);
2530 asprintf (&msg, "Index '%%ld' of dimension %d "
2531 "below lower bound of %%ld", n+1);
2533 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2535 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2536 fold_convert (long_integer_type_node, index),
2537 fold_convert (long_integer_type_node, tmp_lo));
2545 /* Return the offset for an index. Performs bound checking for elemental
2546 dimensions. Single element references are processed separately.
2547 DIM is the array dimension, I is the loop dimension. */
2550 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2551 gfc_array_ref * ar, tree stride)
2553 gfc_array_info *info;
2558 info = &ss->data.info;
2560 /* Get the index into the array for this dimension. */
2563 gcc_assert (ar->type != AR_ELEMENT);
2564 switch (ar->dimen_type[dim])
2566 case DIMEN_THIS_IMAGE:
2570 /* Elemental dimension. */
2571 gcc_assert (info->subscript[dim]
2572 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2573 /* We've already translated this value outside the loop. */
2574 index = info->subscript[dim]->data.scalar.expr;
2576 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2577 ar->as->type != AS_ASSUMED_SIZE
2578 || dim < ar->dimen - 1);
2582 gcc_assert (info && se->loop);
2583 gcc_assert (info->subscript[dim]
2584 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2585 desc = info->subscript[dim]->data.info.descriptor;
2587 /* Get a zero-based index into the vector. */
2588 index = fold_build2_loc (input_location, MINUS_EXPR,
2589 gfc_array_index_type,
2590 se->loop->loopvar[i], se->loop->from[i]);
2592 /* Multiply the index by the stride. */
2593 index = fold_build2_loc (input_location, MULT_EXPR,
2594 gfc_array_index_type,
2595 index, gfc_conv_array_stride (desc, 0));
2597 /* Read the vector to get an index into info->descriptor. */
2598 data = build_fold_indirect_ref_loc (input_location,
2599 gfc_conv_array_data (desc));
2600 index = gfc_build_array_ref (data, index, NULL);
2601 index = gfc_evaluate_now (index, &se->pre);
2602 index = fold_convert (gfc_array_index_type, index);
2604 /* Do any bounds checking on the final info->descriptor index. */
2605 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2606 ar->as->type != AS_ASSUMED_SIZE
2607 || dim < ar->dimen - 1);
2611 /* Scalarized dimension. */
2612 gcc_assert (info && se->loop);
2614 /* Multiply the loop variable by the stride and delta. */
2615 index = se->loop->loopvar[i];
2616 if (!integer_onep (info->stride[dim]))
2617 index = fold_build2_loc (input_location, MULT_EXPR,
2618 gfc_array_index_type, index,
2620 if (!integer_zerop (info->delta[dim]))
2621 index = fold_build2_loc (input_location, PLUS_EXPR,
2622 gfc_array_index_type, index,
2632 /* Temporary array or derived type component. */
2633 gcc_assert (se->loop);
2634 index = se->loop->loopvar[se->loop->order[i]];
2636 /* Pointer functions can have stride[0] different from unity.
2637 Use the stride returned by the function call and stored in
2638 the descriptor for the temporary. */
2639 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2640 && se->ss->info->expr
2641 && se->ss->info->expr->symtree
2642 && se->ss->info->expr->symtree->n.sym->result
2643 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2644 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2647 if (!integer_zerop (info->delta[dim]))
2648 index = fold_build2_loc (input_location, PLUS_EXPR,
2649 gfc_array_index_type, index, info->delta[dim]);
2652 /* Multiply by the stride. */
2653 if (!integer_onep (stride))
2654 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2661 /* Build a scalarized reference to an array. */
2664 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2666 gfc_array_info *info;
2667 tree decl = NULL_TREE;
2675 expr = ss->info->expr;
2676 info = &ss->data.info;
2678 n = se->loop->order[0];
2682 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
2683 /* Add the offset for this dimension to the stored offset for all other
2685 if (!integer_zerop (info->offset))
2686 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2687 index, info->offset);
2689 if (expr && is_subref_array (expr))
2690 decl = expr->symtree->n.sym->backend_decl;
2692 tmp = build_fold_indirect_ref_loc (input_location, info->data);
2693 se->expr = gfc_build_array_ref (tmp, index, decl);
2697 /* Translate access of temporary array. */
2700 gfc_conv_tmp_array_ref (gfc_se * se)
2702 se->string_length = se->ss->info->string_length;
2703 gfc_conv_scalarized_array_ref (se, NULL);
2704 gfc_advance_se_ss_chain (se);
2707 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
2710 add_to_offset (tree *cst_offset, tree *offset, tree t)
2712 if (TREE_CODE (t) == INTEGER_CST)
2713 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2716 if (!integer_zerop (*offset))
2717 *offset = fold_build2_loc (input_location, PLUS_EXPR,
2718 gfc_array_index_type, *offset, t);
2724 /* Build an array reference. se->expr already holds the array descriptor.
2725 This should be either a variable, indirect variable reference or component
2726 reference. For arrays which do not have a descriptor, se->expr will be
2728 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2731 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2735 tree offset, cst_offset;
2743 gcc_assert (ar->codimen);
2745 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2746 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2749 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2750 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2751 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2753 /* Use the actual tree type and not the wrapped coarray. */
2754 if (!se->want_pointer)
2755 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2762 /* Handle scalarized references separately. */
2763 if (ar->type != AR_ELEMENT)
2765 gfc_conv_scalarized_array_ref (se, ar);
2766 gfc_advance_se_ss_chain (se);
2770 cst_offset = offset = gfc_index_zero_node;
2771 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2773 /* Calculate the offsets from all the dimensions. Make sure to associate
2774 the final offset so that we form a chain of loop invariant summands. */
2775 for (n = ar->dimen - 1; n >= 0; n--)
2777 /* Calculate the index for this dimension. */
2778 gfc_init_se (&indexse, se);
2779 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2780 gfc_add_block_to_block (&se->pre, &indexse.pre);
2782 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2784 /* Check array bounds. */
2788 /* Evaluate the indexse.expr only once. */
2789 indexse.expr = save_expr (indexse.expr);
2792 tmp = gfc_conv_array_lbound (se->expr, n);
2793 if (sym->attr.temporary)
2795 gfc_init_se (&tmpse, se);
2796 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2797 gfc_array_index_type);
2798 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2802 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2804 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2805 "below lower bound of %%ld", n+1, sym->name);
2806 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2807 fold_convert (long_integer_type_node,
2809 fold_convert (long_integer_type_node, tmp));
2812 /* Upper bound, but not for the last dimension of assumed-size
2814 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2816 tmp = gfc_conv_array_ubound (se->expr, n);
2817 if (sym->attr.temporary)
2819 gfc_init_se (&tmpse, se);
2820 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2821 gfc_array_index_type);
2822 gfc_add_block_to_block (&se->pre, &tmpse.pre);
2826 cond = fold_build2_loc (input_location, GT_EXPR,
2827 boolean_type_node, indexse.expr, tmp);
2828 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2829 "above upper bound of %%ld", n+1, sym->name);
2830 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2831 fold_convert (long_integer_type_node,
2833 fold_convert (long_integer_type_node, tmp));
2838 /* Multiply the index by the stride. */
2839 stride = gfc_conv_array_stride (se->expr, n);
2840 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2841 indexse.expr, stride);
2843 /* And add it to the total. */
2844 add_to_offset (&cst_offset, &offset, tmp);
2847 if (!integer_zerop (cst_offset))
2848 offset = fold_build2_loc (input_location, PLUS_EXPR,
2849 gfc_array_index_type, offset, cst_offset);
2851 /* Access the calculated element. */
2852 tmp = gfc_conv_array_data (se->expr);
2853 tmp = build_fold_indirect_ref (tmp);
2854 se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
2858 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
2859 LOOP_DIM dimension (if any) to array's offset. */
2862 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
2863 gfc_array_ref *ar, int array_dim, int loop_dim)
2866 gfc_array_info *info;
2869 info = &ss->data.info;
2871 gfc_init_se (&se, NULL);
2873 se.expr = info->descriptor;
2874 stride = gfc_conv_array_stride (info->descriptor, array_dim);
2875 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
2876 gfc_add_block_to_block (pblock, &se.pre);
2878 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
2879 gfc_array_index_type,
2880 info->offset, index);
2881 info->offset = gfc_evaluate_now (info->offset, pblock);
2885 /* Generate the code to be executed immediately before entering a
2886 scalarization loop. */
2889 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2890 stmtblock_t * pblock)
2893 gfc_array_info *info;
2894 gfc_ss_type ss_type;
2899 /* This code will be executed before entering the scalarization loop
2900 for this dimension. */
2901 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2903 if ((ss->useflags & flag) == 0)
2906 ss_type = ss->info->type;
2907 if (ss_type != GFC_SS_SECTION
2908 && ss_type != GFC_SS_FUNCTION
2909 && ss_type != GFC_SS_CONSTRUCTOR
2910 && ss_type != GFC_SS_COMPONENT)
2913 info = &ss->data.info;
2915 gcc_assert (dim < ss->dimen);
2916 gcc_assert (ss->dimen == loop->dimen);
2919 ar = &info->ref->u.ar;
2923 if (dim == loop->dimen - 1)
2928 /* For the time being, there is no loop reordering. */
2929 gcc_assert (i == loop->order[i]);
2932 if (dim == loop->dimen - 1)
2934 stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]);
2936 /* Calculate the stride of the innermost loop. Hopefully this will
2937 allow the backend optimizers to do their stuff more effectively.
2939 info->stride0 = gfc_evaluate_now (stride, pblock);
2941 /* For the outermost loop calculate the offset due to any
2942 elemental dimensions. It will have been initialized with the
2943 base offset of the array. */
2946 for (i = 0; i < ar->dimen; i++)
2948 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2951 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
2956 /* Add the offset for the previous loop dimension. */
2957 add_array_offset (pblock, loop, ss, ar, ss->dim[i], i);
2959 /* Remember this offset for the second loop. */
2960 if (dim == loop->temp_dim - 1)
2961 info->saved_offset = info->offset;
2966 /* Start a scalarized expression. Creates a scope and declares loop
2970 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2976 gcc_assert (!loop->array_parameter);
2978 for (dim = loop->dimen - 1; dim >= 0; dim--)
2980 n = loop->order[dim];
2982 gfc_start_block (&loop->code[n]);
2984 /* Create the loop variable. */
2985 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2987 if (dim < loop->temp_dim)
2991 /* Calculate values that will be constant within this loop. */
2992 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2994 gfc_start_block (pbody);
2998 /* Generates the actual loop code for a scalarization loop. */
3001 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3002 stmtblock_t * pbody)
3013 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3014 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3015 && n == loop->dimen - 1)
3017 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3018 init = make_tree_vec (1);
3019 cond = make_tree_vec (1);
3020 incr = make_tree_vec (1);
3022 /* Cycle statement is implemented with a goto. Exit statement must not
3023 be present for this loop. */
3024 exit_label = gfc_build_label_decl (NULL_TREE);
3025 TREE_USED (exit_label) = 1;
3027 /* Label for cycle statements (if needed). */
3028 tmp = build1_v (LABEL_EXPR, exit_label);
3029 gfc_add_expr_to_block (pbody, tmp);
3031 stmt = make_node (OMP_FOR);
3033 TREE_TYPE (stmt) = void_type_node;
3034 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3036 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3037 OMP_CLAUSE_SCHEDULE);
3038 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3039 = OMP_CLAUSE_SCHEDULE_STATIC;
3040 if (ompws_flags & OMPWS_NOWAIT)
3041 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3042 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3044 /* Initialize the loopvar. */
3045 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3047 OMP_FOR_INIT (stmt) = init;
3048 /* The exit condition. */
3049 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3051 loop->loopvar[n], loop->to[n]);
3052 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3053 OMP_FOR_COND (stmt) = cond;
3054 /* Increment the loopvar. */
3055 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3056 loop->loopvar[n], gfc_index_one_node);
3057 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3058 void_type_node, loop->loopvar[n], tmp);
3059 OMP_FOR_INCR (stmt) = incr;
3061 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3062 gfc_add_expr_to_block (&loop->code[n], stmt);
3066 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3067 && (loop->temp_ss == NULL);
3069 loopbody = gfc_finish_block (pbody);
3073 tmp = loop->from[n];
3074 loop->from[n] = loop->to[n];
3078 /* Initialize the loopvar. */
3079 if (loop->loopvar[n] != loop->from[n])
3080 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3082 exit_label = gfc_build_label_decl (NULL_TREE);
3084 /* Generate the loop body. */
3085 gfc_init_block (&block);
3087 /* The exit condition. */
3088 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3089 boolean_type_node, loop->loopvar[n], loop->to[n]);
3090 tmp = build1_v (GOTO_EXPR, exit_label);
3091 TREE_USED (exit_label) = 1;
3092 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3093 gfc_add_expr_to_block (&block, tmp);
3095 /* The main body. */
3096 gfc_add_expr_to_block (&block, loopbody);
3098 /* Increment the loopvar. */
3099 tmp = fold_build2_loc (input_location,
3100 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3101 gfc_array_index_type, loop->loopvar[n],
3102 gfc_index_one_node);
3104 gfc_add_modify (&block, loop->loopvar[n], tmp);
3106 /* Build the loop. */
3107 tmp = gfc_finish_block (&block);
3108 tmp = build1_v (LOOP_EXPR, tmp);
3109 gfc_add_expr_to_block (&loop->code[n], tmp);
3111 /* Add the exit label. */
3112 tmp = build1_v (LABEL_EXPR, exit_label);
3113 gfc_add_expr_to_block (&loop->code[n], tmp);
3119 /* Finishes and generates the loops for a scalarized expression. */
3122 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3127 stmtblock_t *pblock;
3131 /* Generate the loops. */
3132 for (dim = 0; dim < loop->dimen; dim++)
3134 n = loop->order[dim];
3135 gfc_trans_scalarized_loop_end (loop, n, pblock);
3136 loop->loopvar[n] = NULL_TREE;
3137 pblock = &loop->code[n];
3140 tmp = gfc_finish_block (pblock);
3141 gfc_add_expr_to_block (&loop->pre, tmp);
3143 /* Clear all the used flags. */
3144 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3149 /* Finish the main body of a scalarized expression, and start the secondary
3153 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3157 stmtblock_t *pblock;
3161 /* We finish as many loops as are used by the temporary. */
3162 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3164 n = loop->order[dim];
3165 gfc_trans_scalarized_loop_end (loop, n, pblock);
3166 loop->loopvar[n] = NULL_TREE;
3167 pblock = &loop->code[n];
3170 /* We don't want to finish the outermost loop entirely. */
3171 n = loop->order[loop->temp_dim - 1];
3172 gfc_trans_scalarized_loop_end (loop, n, pblock);
3174 /* Restore the initial offsets. */
3175 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3177 gfc_ss_type ss_type;
3179 if ((ss->useflags & 2) == 0)
3182 ss_type = ss->info->type;
3183 if (ss_type != GFC_SS_SECTION
3184 && ss_type != GFC_SS_FUNCTION
3185 && ss_type != GFC_SS_CONSTRUCTOR
3186 && ss_type != GFC_SS_COMPONENT)
3189 ss->data.info.offset = ss->data.info.saved_offset;
3192 /* Restart all the inner loops we just finished. */
3193 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3195 n = loop->order[dim];
3197 gfc_start_block (&loop->code[n]);
3199 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3201 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3204 /* Start a block for the secondary copying code. */
3205 gfc_start_block (body);
3209 /* Precalculate (either lower or upper) bound of an array section.
3210 BLOCK: Block in which the (pre)calculation code will go.
3211 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3212 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3213 DESC: Array descriptor from which the bound will be picked if unspecified
3214 (either lower or upper bound according to LBOUND). */
3217 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3218 tree desc, int dim, bool lbound)
3221 gfc_expr * input_val = values[dim];
3222 tree *output = &bounds[dim];
3227 /* Specified section bound. */
3228 gfc_init_se (&se, NULL);
3229 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3230 gfc_add_block_to_block (block, &se.pre);
3235 /* No specific bound specified so use the bound of the array. */
3236 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3237 gfc_conv_array_ubound (desc, dim);
3239 *output = gfc_evaluate_now (*output, block);
3243 /* Calculate the lower bound of an array section. */
3246 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
3248 gfc_expr *stride = NULL;
3251 gfc_array_info *info;
3254 gcc_assert (ss->info->type == GFC_SS_SECTION);
3256 info = &ss->data.info;
3257 ar = &info->ref->u.ar;
3259 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3261 /* We use a zero-based index to access the vector. */
3262 info->start[dim] = gfc_index_zero_node;
3263 info->end[dim] = NULL;
3264 info->stride[dim] = gfc_index_one_node;
3268 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3269 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3270 desc = info->descriptor;
3271 stride = ar->stride[dim];
3273 /* Calculate the start of the range. For vector subscripts this will
3274 be the range of the vector. */
3275 evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
3277 /* Similarly calculate the end. Although this is not used in the
3278 scalarizer, it is needed when checking bounds and where the end
3279 is an expression with side-effects. */
3280 evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
3282 /* Calculate the stride. */
3284 info->stride[dim] = gfc_index_one_node;
3287 gfc_init_se (&se, NULL);
3288 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3289 gfc_add_block_to_block (&loop->pre, &se.pre);
3290 info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
3295 /* Calculates the range start and stride for a SS chain. Also gets the
3296 descriptor and data pointer. The range of vector subscripts is the size
3297 of the vector. Array bounds are also checked. */
3300 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3308 /* Determine the rank of the loop. */
3309 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3311 switch (ss->info->type)
3313 case GFC_SS_SECTION:
3314 case GFC_SS_CONSTRUCTOR:
3315 case GFC_SS_FUNCTION:
3316 case GFC_SS_COMPONENT:
3317 loop->dimen = ss->dimen;
3320 /* As usual, lbound and ubound are exceptions!. */
3321 case GFC_SS_INTRINSIC:
3322 switch (ss->info->expr->value.function.isym->id)
3324 case GFC_ISYM_LBOUND:
3325 case GFC_ISYM_UBOUND:
3326 case GFC_ISYM_LCOBOUND:
3327 case GFC_ISYM_UCOBOUND:
3328 case GFC_ISYM_THIS_IMAGE:
3329 loop->dimen = ss->dimen;
3341 /* We should have determined the rank of the expression by now. If
3342 not, that's bad news. */
3346 /* Loop over all the SS in the chain. */
3347 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3349 gfc_ss_info *ss_info;
3350 gfc_array_info *info;
3354 expr = ss_info->expr;
3355 info = &ss->data.info;
3357 if (expr && expr->shape && !info->shape)
3358 info->shape = expr->shape;
3360 switch (ss_info->type)
3362 case GFC_SS_SECTION:
3363 /* Get the descriptor for the array. */
3364 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3366 for (n = 0; n < ss->dimen; n++)
3367 gfc_conv_section_startstride (loop, ss, ss->dim[n]);
3370 case GFC_SS_INTRINSIC:
3371 switch (expr->value.function.isym->id)
3373 /* Fall through to supply start and stride. */
3374 case GFC_ISYM_LBOUND:
3375 case GFC_ISYM_UBOUND:
3376 case GFC_ISYM_LCOBOUND:
3377 case GFC_ISYM_UCOBOUND:
3378 case GFC_ISYM_THIS_IMAGE:
3385 case GFC_SS_CONSTRUCTOR:
3386 case GFC_SS_FUNCTION:
3387 for (n = 0; n < ss->dimen; n++)
3389 int dim = ss->dim[n];
3391 ss->data.info.start[dim] = gfc_index_zero_node;
3392 ss->data.info.end[dim] = gfc_index_zero_node;
3393 ss->data.info.stride[dim] = gfc_index_one_node;
3402 /* The rest is just runtime bound checking. */
3403 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3406 tree lbound, ubound;
3408 tree size[GFC_MAX_DIMENSIONS];
3409 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3410 gfc_array_info *info;
3414 gfc_start_block (&block);
3416 for (n = 0; n < loop->dimen; n++)
3417 size[n] = NULL_TREE;
3419 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3422 gfc_ss_info *ss_info;
3425 const char *expr_name;
3428 if (ss_info->type != GFC_SS_SECTION)
3431 /* Catch allocatable lhs in f2003. */
3432 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3435 expr = ss_info->expr;
3436 expr_loc = &expr->where;
3437 expr_name = expr->symtree->name;
3439 gfc_start_block (&inner);
3441 /* TODO: range checking for mapped dimensions. */
3442 info = &ss->data.info;
3444 /* This code only checks ranges. Elemental and vector
3445 dimensions are checked later. */
3446 for (n = 0; n < loop->dimen; n++)
3451 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3454 if (dim == info->ref->u.ar.dimen - 1
3455 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3456 check_upper = false;
3460 /* Zero stride is not allowed. */
3461 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3462 info->stride[dim], gfc_index_zero_node);
3463 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3464 "of array '%s'", dim + 1, expr_name);
3465 gfc_trans_runtime_check (true, false, tmp, &inner,
3469 desc = ss->data.info.descriptor;
3471 /* This is the run-time equivalent of resolve.c's
3472 check_dimension(). The logical is more readable there
3473 than it is here, with all the trees. */
3474 lbound = gfc_conv_array_lbound (desc, dim);
3475 end = info->end[dim];
3477 ubound = gfc_conv_array_ubound (desc, dim);
3481 /* non_zerosized is true when the selected range is not
3483 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3484 boolean_type_node, info->stride[dim],
3485 gfc_index_zero_node);
3486 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3487 info->start[dim], end);
3488 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3489 boolean_type_node, stride_pos, tmp);
3491 stride_neg = fold_build2_loc (input_location, LT_EXPR,
3493 info->stride[dim], gfc_index_zero_node);
3494 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3495 info->start[dim], end);
3496 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3499 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3501 stride_pos, stride_neg);
3503 /* Check the start of the range against the lower and upper
3504 bounds of the array, if the range is not empty.
3505 If upper bound is present, include both bounds in the
3509 tmp = fold_build2_loc (input_location, LT_EXPR,
3511 info->start[dim], lbound);
3512 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3514 non_zerosized, tmp);
3515 tmp2 = fold_build2_loc (input_location, GT_EXPR,
3517 info->start[dim], ubound);
3518 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3520 non_zerosized, tmp2);
3521 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3522 "outside of expected range (%%ld:%%ld)",
3523 dim + 1, expr_name);
3524 gfc_trans_runtime_check (true, false, tmp, &inner,
3526 fold_convert (long_integer_type_node, info->start[dim]),
3527 fold_convert (long_integer_type_node, lbound),
3528 fold_convert (long_integer_type_node, ubound));
3529 gfc_trans_runtime_check (true, false, tmp2, &inner,
3531 fold_convert (long_integer_type_node, info->start[dim]),
3532 fold_convert (long_integer_type_node, lbound),
3533 fold_convert (long_integer_type_node, ubound));
3538 tmp = fold_build2_loc (input_location, LT_EXPR,
3540 info->start[dim], lbound);
3541 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3542 boolean_type_node, non_zerosized, tmp);
3543 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3544 "below lower bound of %%ld",
3545 dim + 1, expr_name);
3546 gfc_trans_runtime_check (true, false, tmp, &inner,
3548 fold_convert (long_integer_type_node, info->start[dim]),
3549 fold_convert (long_integer_type_node, lbound));
3553 /* Compute the last element of the range, which is not
3554 necessarily "end" (think 0:5:3, which doesn't contain 5)
3555 and check it against both lower and upper bounds. */
3557 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3558 gfc_array_index_type, end,
3560 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
3561 gfc_array_index_type, tmp,
3563 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3564 gfc_array_index_type, end, tmp);
3565 tmp2 = fold_build2_loc (input_location, LT_EXPR,
3566 boolean_type_node, tmp, lbound);
3567 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3568 boolean_type_node, non_zerosized, tmp2);
3571 tmp3 = fold_build2_loc (input_location, GT_EXPR,
3572 boolean_type_node, tmp, ubound);
3573 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3574 boolean_type_node, non_zerosized, tmp3);
3575 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3576 "outside of expected range (%%ld:%%ld)",
3577 dim + 1, expr_name);
3578 gfc_trans_runtime_check (true, false, tmp2, &inner,
3580 fold_convert (long_integer_type_node, tmp),
3581 fold_convert (long_integer_type_node, ubound),
3582 fold_convert (long_integer_type_node, lbound));
3583 gfc_trans_runtime_check (true, false, tmp3, &inner,
3585 fold_convert (long_integer_type_node, tmp),
3586 fold_convert (long_integer_type_node, ubound),
3587 fold_convert (long_integer_type_node, lbound));
3592 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3593 "below lower bound of %%ld",
3594 dim + 1, expr_name);
3595 gfc_trans_runtime_check (true, false, tmp2, &inner,
3597 fold_convert (long_integer_type_node, tmp),
3598 fold_convert (long_integer_type_node, lbound));
3602 /* Check the section sizes match. */
3603 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3604 gfc_array_index_type, end,
3606 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
3607 gfc_array_index_type, tmp,
3609 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3610 gfc_array_index_type,
3611 gfc_index_one_node, tmp);
3612 tmp = fold_build2_loc (input_location, MAX_EXPR,
3613 gfc_array_index_type, tmp,
3614 build_int_cst (gfc_array_index_type, 0));
3615 /* We remember the size of the first section, and check all the
3616 others against this. */
3619 tmp3 = fold_build2_loc (input_location, NE_EXPR,
3620 boolean_type_node, tmp, size[n]);
3621 asprintf (&msg, "Array bound mismatch for dimension %d "
3622 "of array '%s' (%%ld/%%ld)",
3623 dim + 1, expr_name);
3625 gfc_trans_runtime_check (true, false, tmp3, &inner,
3627 fold_convert (long_integer_type_node, tmp),
3628 fold_convert (long_integer_type_node, size[n]));
3633 size[n] = gfc_evaluate_now (tmp, &inner);
3636 tmp = gfc_finish_block (&inner);
3638 /* For optional arguments, only check bounds if the argument is
3640 if (expr->symtree->n.sym->attr.optional
3641 || expr->symtree->n.sym->attr.not_always_present)
3642 tmp = build3_v (COND_EXPR,
3643 gfc_conv_expr_present (expr->symtree->n.sym),
3644 tmp, build_empty_stmt (input_location));
3646 gfc_add_expr_to_block (&block, tmp);
3650 tmp = gfc_finish_block (&block);
3651 gfc_add_expr_to_block (&loop->pre, tmp);
3655 /* Return true if both symbols could refer to the same data object. Does
3656 not take account of aliasing due to equivalence statements. */
3659 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
3660 bool lsym_target, bool rsym_pointer, bool rsym_target)
3662 /* Aliasing isn't possible if the symbols have different base types. */
3663 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
3666 /* Pointers can point to other pointers and target objects. */
3668 if ((lsym_pointer && (rsym_pointer || rsym_target))
3669 || (rsym_pointer && (lsym_pointer || lsym_target)))
3672 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
3673 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
3675 if (lsym_target && rsym_target
3676 && ((lsym->attr.dummy && !lsym->attr.contiguous
3677 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
3678 || (rsym->attr.dummy && !rsym->attr.contiguous
3679 && (!rsym->attr.dimension
3680 || rsym->as->type == AS_ASSUMED_SHAPE))))
3687 /* Return true if the two SS could be aliased, i.e. both point to the same data
3689 /* TODO: resolve aliases based on frontend expressions. */
3692 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3696 gfc_expr *lexpr, *rexpr;
3699 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
3701 lexpr = lss->info->expr;
3702 rexpr = rss->info->expr;
3704 lsym = lexpr->symtree->n.sym;
3705 rsym = rexpr->symtree->n.sym;
3707 lsym_pointer = lsym->attr.pointer;
3708 lsym_target = lsym->attr.target;
3709 rsym_pointer = rsym->attr.pointer;
3710 rsym_target = rsym->attr.target;
3712 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
3713 rsym_pointer, rsym_target))
3716 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
3717 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
3720 /* For derived types we must check all the component types. We can ignore
3721 array references as these will have the same base type as the previous
3723 for (lref = lexpr->ref; lref != lss->data.info.ref; lref = lref->next)
3725 if (lref->type != REF_COMPONENT)
3728 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
3729 lsym_target = lsym_target || lref->u.c.sym->attr.target;
3731 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
3732 rsym_pointer, rsym_target))
3735 if ((lsym_pointer && (rsym_pointer || rsym_target))
3736 || (rsym_pointer && (lsym_pointer || lsym_target)))
3738 if (gfc_compare_types (&lref->u.c.component->ts,
3743 for (rref = rexpr->ref; rref != rss->data.info.ref;
3746 if (rref->type != REF_COMPONENT)
3749 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3750 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3752 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
3753 lsym_pointer, lsym_target,
3754 rsym_pointer, rsym_target))
3757 if ((lsym_pointer && (rsym_pointer || rsym_target))
3758 || (rsym_pointer && (lsym_pointer || lsym_target)))
3760 if (gfc_compare_types (&lref->u.c.component->ts,
3761 &rref->u.c.sym->ts))
3763 if (gfc_compare_types (&lref->u.c.sym->ts,
3764 &rref->u.c.component->ts))
3766 if (gfc_compare_types (&lref->u.c.component->ts,
3767 &rref->u.c.component->ts))
3773 lsym_pointer = lsym->attr.pointer;
3774 lsym_target = lsym->attr.target;
3775 lsym_pointer = lsym->attr.pointer;
3776 lsym_target = lsym->attr.target;
3778 for (rref = rexpr->ref; rref != rss->data.info.ref; rref = rref->next)
3780 if (rref->type != REF_COMPONENT)
3783 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
3784 rsym_target = lsym_target || rref->u.c.sym->attr.target;
3786 if (symbols_could_alias (rref->u.c.sym, lsym,
3787 lsym_pointer, lsym_target,
3788 rsym_pointer, rsym_target))
3791 if ((lsym_pointer && (rsym_pointer || rsym_target))
3792 || (rsym_pointer && (lsym_pointer || lsym_target)))
3794 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
3803 /* Resolve array data dependencies. Creates a temporary if required. */
3804 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3808 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3814 gfc_expr *dest_expr;
3819 loop->temp_ss = NULL;
3820 dest_expr = dest->info->expr;
3822 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3824 if (ss->info->type != GFC_SS_SECTION)
3827 ss_expr = ss->info->expr;
3829 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
3831 if (gfc_could_be_alias (dest, ss)
3832 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
3840 lref = dest_expr->ref;
3841 rref = ss_expr->ref;
3843 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
3848 for (i = 0; i < dest->dimen; i++)
3849 for (j = 0; j < ss->dimen; j++)
3851 && dest->dim[i] == ss->dim[j])
3853 /* If we don't access array elements in the same order,
3854 there is a dependency. */
3859 /* TODO : loop shifting. */
3862 /* Mark the dimensions for LOOP SHIFTING */
3863 for (n = 0; n < loop->dimen; n++)
3865 int dim = dest->data.info.dim[n];
3867 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3869 else if (! gfc_is_same_range (&lref->u.ar,
3870 &rref->u.ar, dim, 0))
3874 /* Put all the dimensions with dependencies in the
3877 for (n = 0; n < loop->dimen; n++)
3879 gcc_assert (loop->order[n] == n);
3881 loop->order[dim++] = n;
3883 for (n = 0; n < loop->dimen; n++)
3886 loop->order[dim++] = n;
3889 gcc_assert (dim == loop->dimen);
3900 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
3901 if (GFC_ARRAY_TYPE_P (base_type)
3902 || GFC_DESCRIPTOR_TYPE_P (base_type))
3903 base_type = gfc_get_element_type (base_type);
3904 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
3906 gfc_add_ss_to_loop (loop, loop->temp_ss);
3909 loop->temp_ss = NULL;
3913 /* Initialize the scalarization loop. Creates the loop variables. Determines
3914 the range of the loop variables. Creates a temporary if required.
3915 Calculates how to transform from loop variables to array indices for each
3916 expression. Also generates code for scalar expressions which have been
3917 moved outside the loop. */
3920 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3922 int n, dim, spec_dim;
3923 gfc_array_info *info;
3924 gfc_array_info *specinfo;
3925 gfc_ss *ss, *tmp_ss;
3927 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3928 bool dynamic[GFC_MAX_DIMENSIONS];
3933 for (n = 0; n < loop->dimen; n++)
3937 /* We use one SS term, and use that to determine the bounds of the
3938 loop for this dimension. We try to pick the simplest term. */
3939 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3941 gfc_ss_type ss_type;
3943 ss_type = ss->info->type;
3944 if (ss_type == GFC_SS_SCALAR
3945 || ss_type == GFC_SS_TEMP
3946 || ss_type == GFC_SS_REFERENCE)
3949 info = &ss->data.info;
3952 if (loopspec[n] != NULL)
3954 specinfo = &loopspec[n]->data.info;
3955 spec_dim = loopspec[n]->dim[n];
3959 /* Silence unitialized warnings. */
3966 gcc_assert (info->shape[dim]);
3967 /* The frontend has worked out the size for us. */
3970 || !integer_zerop (specinfo->start[spec_dim]))
3971 /* Prefer zero-based descriptors if possible. */
3976 if (ss_type == GFC_SS_CONSTRUCTOR)
3978 gfc_constructor_base base;
3979 /* An unknown size constructor will always be rank one.
3980 Higher rank constructors will either have known shape,
3981 or still be wrapped in a call to reshape. */
3982 gcc_assert (loop->dimen == 1);
3984 /* Always prefer to use the constructor bounds if the size
3985 can be determined at compile time. Prefer not to otherwise,
3986 since the general case involves realloc, and it's better to
3987 avoid that overhead if possible. */
3988 base = ss->info->expr->value.constructor;
3989 dynamic[n] = gfc_get_array_constructor_size (&i, base);
3990 if (!dynamic[n] || !loopspec[n])
3995 /* TODO: Pick the best bound if we have a choice between a
3996 function and something else. */
3997 if (ss_type == GFC_SS_FUNCTION)
4003 /* Avoid using an allocatable lhs in an assignment, since
4004 there might be a reallocation coming. */
4005 if (loopspec[n] && ss->is_alloc_lhs)
4008 if (ss_type != GFC_SS_SECTION)
4013 /* Criteria for choosing a loop specifier (most important first):
4014 doesn't need realloc
4020 else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4021 || n >= loop->dimen)
4023 else if (integer_onep (info->stride[dim])
4024 && !integer_onep (specinfo->stride[spec_dim]))
4026 else if (INTEGER_CST_P (info->stride[dim])
4027 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4029 else if (INTEGER_CST_P (info->start[dim])
4030 && !INTEGER_CST_P (specinfo->start[spec_dim]))
4032 /* We don't work out the upper bound.
4033 else if (INTEGER_CST_P (info->finish[n])
4034 && ! INTEGER_CST_P (specinfo->finish[n]))
4035 loopspec[n] = ss; */
4038 /* We should have found the scalarization loop specifier. If not,
4040 gcc_assert (loopspec[n]);
4042 info = &loopspec[n]->data.info;
4043 dim = loopspec[n]->dim[n];
4045 /* Set the extents of this range. */
4046 cshape = info->shape;
4047 if (cshape && INTEGER_CST_P (info->start[dim])
4048 && INTEGER_CST_P (info->stride[dim]))
4050 loop->from[n] = info->start[dim];
4051 mpz_set (i, cshape[get_array_ref_dim (loopspec[n], n)]);
4052 mpz_sub_ui (i, i, 1);
4053 /* To = from + (size - 1) * stride. */
4054 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4055 if (!integer_onep (info->stride[dim]))
4056 tmp = fold_build2_loc (input_location, MULT_EXPR,
4057 gfc_array_index_type, tmp,
4059 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4060 gfc_array_index_type,
4061 loop->from[n], tmp);
4065 loop->from[n] = info->start[dim];
4066 switch (loopspec[n]->info->type)
4068 case GFC_SS_CONSTRUCTOR:
4069 /* The upper bound is calculated when we expand the
4071 gcc_assert (loop->to[n] == NULL_TREE);
4074 case GFC_SS_SECTION:
4075 /* Use the end expression if it exists and is not constant,
4076 so that it is only evaluated once. */
4077 loop->to[n] = info->end[dim];
4080 case GFC_SS_FUNCTION:
4081 /* The loop bound will be set when we generate the call. */
4082 gcc_assert (loop->to[n] == NULL_TREE);
4090 /* Transform everything so we have a simple incrementing variable. */
4091 if (n < loop->dimen && integer_onep (info->stride[dim]))
4092 info->delta[dim] = gfc_index_zero_node;
4093 else if (n < loop->dimen)
4095 /* Set the delta for this section. */
4096 info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
4097 /* Number of iterations is (end - start + step) / step.
4098 with start = 0, this simplifies to
4100 for (i = 0; i<=last; i++){...}; */
4101 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4102 gfc_array_index_type, loop->to[n],
4104 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4105 gfc_array_index_type, tmp, info->stride[dim]);
4106 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4107 tmp, build_int_cst (gfc_array_index_type, -1));
4108 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
4109 /* Make the loop variable start at 0. */
4110 loop->from[n] = gfc_index_zero_node;
4114 /* Add all the scalar code that can be taken out of the loops.
4115 This may include calculating the loop bounds, so do it before
4116 allocating the temporary. */
4117 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4119 tmp_ss = loop->temp_ss;
4120 /* If we want a temporary then create it. */
4123 gfc_ss_info *tmp_ss_info;
4125 tmp_ss_info = tmp_ss->info;
4126 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4128 /* Make absolutely sure that this is a complete type. */
4129 if (tmp_ss_info->string_length)
4130 loop->temp_ss->data.temp.type
4131 = gfc_get_character_type_len_for_eltype
4132 (TREE_TYPE (loop->temp_ss->data.temp.type),
4133 tmp_ss_info->string_length);
4135 tmp = loop->temp_ss->data.temp.type;
4136 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_array_info));
4137 tmp_ss_info->type = GFC_SS_SECTION;
4139 gcc_assert (tmp_ss->dimen != 0);
4141 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
4142 tmp_ss, tmp, NULL_TREE,
4143 false, true, false, where);
4146 for (n = 0; n < loop->temp_dim; n++)
4147 loopspec[loop->order[n]] = NULL;
4151 /* For array parameters we don't have loop variables, so don't calculate the
4153 if (loop->array_parameter)
4156 /* Calculate the translation from loop variables to array indices. */
4157 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4159 gfc_ss_type ss_type;
4161 ss_type = ss->info->type;
4162 if (ss_type != GFC_SS_SECTION
4163 && ss_type != GFC_SS_COMPONENT
4164 && ss_type != GFC_SS_CONSTRUCTOR)
4167 info = &ss->data.info;
4169 for (n = 0; n < ss->dimen; n++)
4171 /* If we are specifying the range the delta is already set. */
4172 if (loopspec[n] != ss)
4176 /* Calculate the offset relative to the loop variable.
4177 First multiply by the stride. */
4178 tmp = loop->from[n];
4179 if (!integer_onep (info->stride[dim]))
4180 tmp = fold_build2_loc (input_location, MULT_EXPR,
4181 gfc_array_index_type,
4182 tmp, info->stride[dim]);
4184 /* Then subtract this from our starting value. */
4185 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4186 gfc_array_index_type,
4187 info->start[dim], tmp);
4189 info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
4196 /* Calculate the size of a given array dimension from the bounds. This
4197 is simply (ubound - lbound + 1) if this expression is positive
4198 or 0 if it is negative (pick either one if it is zero). Optionally
4199 (if or_expr is present) OR the (expression != 0) condition to it. */
4202 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4207 /* Calculate (ubound - lbound + 1). */
4208 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4210 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4211 gfc_index_one_node);
4213 /* Check whether the size for this dimension is negative. */
4214 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4215 gfc_index_zero_node);
4216 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4217 gfc_index_zero_node, res);
4219 /* Build OR expression. */
4221 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4222 boolean_type_node, *or_expr, cond);
4228 /* For an array descriptor, get the total number of elements. This is just
4229 the product of the extents along from_dim to to_dim. */
4232 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4237 res = gfc_index_one_node;
4239 for (dim = from_dim; dim < to_dim; ++dim)
4245 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4246 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4248 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4249 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4257 /* Full size of an array. */
4260 gfc_conv_descriptor_size (tree desc, int rank)
4262 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4266 /* Size of a coarray for all dimensions but the last. */
4269 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4271 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4275 /* Fills in an array descriptor, and returns the size of the array.
4276 The size will be a simple_val, ie a variable or a constant. Also
4277 calculates the offset of the base. The pointer argument overflow,
4278 which should be of integer type, will increase in value if overflow
4279 occurs during the size calculation. Returns the size of the array.
4283 for (n = 0; n < rank; n++)
4285 a.lbound[n] = specified_lower_bound;
4286 offset = offset + a.lbond[n] * stride;
4288 a.ubound[n] = specified_upper_bound;
4289 a.stride[n] = stride;
4290 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4291 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4292 stride = stride * size;
4294 for (n = rank; n < rank+corank; n++)
4295 (Set lcobound/ucobound as above.)
4296 element_size = sizeof (array element);
4299 stride = (size_t) stride;
4300 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4301 stride = stride * element_size;
4307 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4308 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4309 stmtblock_t * descriptor_block, tree * overflow)
4322 stmtblock_t thenblock;
4323 stmtblock_t elseblock;
4328 type = TREE_TYPE (descriptor);
4330 stride = gfc_index_one_node;
4331 offset = gfc_index_zero_node;
4333 /* Set the dtype. */
4334 tmp = gfc_conv_descriptor_dtype (descriptor);
4335 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4337 or_expr = boolean_false_node;
4339 for (n = 0; n < rank; n++)
4344 /* We have 3 possibilities for determining the size of the array:
4345 lower == NULL => lbound = 1, ubound = upper[n]
4346 upper[n] = NULL => lbound = 1, ubound = lower[n]
4347 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4350 /* Set lower bound. */
4351 gfc_init_se (&se, NULL);
4353 se.expr = gfc_index_one_node;
4356 gcc_assert (lower[n]);
4359 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4360 gfc_add_block_to_block (pblock, &se.pre);
4364 se.expr = gfc_index_one_node;
4368 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4369 gfc_rank_cst[n], se.expr);
4370 conv_lbound = se.expr;
4372 /* Work out the offset for this component. */
4373 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4375 offset = fold_build2_loc (input_location, MINUS_EXPR,
4376 gfc_array_index_type, offset, tmp);
4378 /* Set upper bound. */
4379 gfc_init_se (&se, NULL);
4380 gcc_assert (ubound);
4381 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4382 gfc_add_block_to_block (pblock, &se.pre);
4384 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4385 gfc_rank_cst[n], se.expr);
4386 conv_ubound = se.expr;
4388 /* Store the stride. */
4389 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4390 gfc_rank_cst[n], stride);
4392 /* Calculate size and check whether extent is negative. */
4393 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4394 size = gfc_evaluate_now (size, pblock);
4396 /* Check whether multiplying the stride by the number of
4397 elements in this dimension would overflow. We must also check
4398 whether the current dimension has zero size in order to avoid
4401 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4402 gfc_array_index_type,
4403 fold_convert (gfc_array_index_type,
4404 TYPE_MAX_VALUE (gfc_array_index_type)),
4406 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4407 boolean_type_node, tmp, stride));
4408 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4409 integer_one_node, integer_zero_node);
4410 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4411 boolean_type_node, size,
4412 gfc_index_zero_node));
4413 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4414 integer_zero_node, tmp);
4415 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4417 *overflow = gfc_evaluate_now (tmp, pblock);
4419 /* Multiply the stride by the number of elements in this dimension. */
4420 stride = fold_build2_loc (input_location, MULT_EXPR,
4421 gfc_array_index_type, stride, size);
4422 stride = gfc_evaluate_now (stride, pblock);
4425 for (n = rank; n < rank + corank; n++)
4429 /* Set lower bound. */
4430 gfc_init_se (&se, NULL);
4431 if (lower == NULL || lower[n] == NULL)
4433 gcc_assert (n == rank + corank - 1);
4434 se.expr = gfc_index_one_node;
4438 if (ubound || n == rank + corank - 1)
4440 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4441 gfc_add_block_to_block (pblock, &se.pre);
4445 se.expr = gfc_index_one_node;
4449 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4450 gfc_rank_cst[n], se.expr);
4452 if (n < rank + corank - 1)
4454 gfc_init_se (&se, NULL);
4455 gcc_assert (ubound);
4456 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4457 gfc_add_block_to_block (pblock, &se.pre);
4458 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4459 gfc_rank_cst[n], se.expr);
4463 /* The stride is the number of elements in the array, so multiply by the
4464 size of an element to get the total size. */
4465 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4466 /* Convert to size_t. */
4467 element_size = fold_convert (size_type_node, tmp);
4470 return element_size;
4472 stride = fold_convert (size_type_node, stride);
4474 /* First check for overflow. Since an array of type character can
4475 have zero element_size, we must check for that before
4477 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4479 TYPE_MAX_VALUE (size_type_node), element_size);
4480 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4481 boolean_type_node, tmp, stride));
4482 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4483 integer_one_node, integer_zero_node);
4484 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4485 boolean_type_node, element_size,
4486 build_int_cst (size_type_node, 0)));
4487 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4488 integer_zero_node, tmp);
4489 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
4491 *overflow = gfc_evaluate_now (tmp, pblock);
4493 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4494 stride, element_size);
4496 if (poffset != NULL)
4498 offset = gfc_evaluate_now (offset, pblock);
4502 if (integer_zerop (or_expr))
4504 if (integer_onep (or_expr))
4505 return build_int_cst (size_type_node, 0);
4507 var = gfc_create_var (TREE_TYPE (size), "size");
4508 gfc_start_block (&thenblock);
4509 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
4510 thencase = gfc_finish_block (&thenblock);
4512 gfc_start_block (&elseblock);
4513 gfc_add_modify (&elseblock, var, size);
4514 elsecase = gfc_finish_block (&elseblock);
4516 tmp = gfc_evaluate_now (or_expr, pblock);
4517 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
4518 gfc_add_expr_to_block (pblock, tmp);
4524 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
4525 the work for an ALLOCATE statement. */
4529 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
4534 tree offset = NULL_TREE;
4535 tree token = NULL_TREE;
4538 tree error = NULL_TREE;
4539 tree overflow; /* Boolean storing whether size calculation overflows. */
4540 tree var_overflow = NULL_TREE;
4542 tree set_descriptor;
4543 stmtblock_t set_descriptor_block;
4544 stmtblock_t elseblock;
4547 gfc_ref *ref, *prev_ref = NULL;
4548 bool allocatable, coarray, dimension;
4552 /* Find the last reference in the chain. */
4553 while (ref && ref->next != NULL)
4555 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
4556 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
4561 if (ref == NULL || ref->type != REF_ARRAY)
4566 allocatable = expr->symtree->n.sym->attr.allocatable;
4567 coarray = expr->symtree->n.sym->attr.codimension;
4568 dimension = expr->symtree->n.sym->attr.dimension;
4572 allocatable = prev_ref->u.c.component->attr.allocatable;
4573 coarray = prev_ref->u.c.component->attr.codimension;
4574 dimension = prev_ref->u.c.component->attr.dimension;
4578 gcc_assert (coarray);
4580 /* Figure out the size of the array. */
4581 switch (ref->u.ar.type)
4587 upper = ref->u.ar.start;
4593 lower = ref->u.ar.start;
4594 upper = ref->u.ar.end;
4598 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
4600 lower = ref->u.ar.as->lower;
4601 upper = ref->u.ar.as->upper;
4609 overflow = integer_zero_node;
4611 gfc_init_block (&set_descriptor_block);
4612 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
4613 ref->u.ar.as->corank, &offset, lower, upper,
4614 &se->pre, &set_descriptor_block, &overflow);
4619 var_overflow = gfc_create_var (integer_type_node, "overflow");
4620 gfc_add_modify (&se->pre, var_overflow, overflow);
4622 /* Generate the block of code handling overflow. */
4623 msg = gfc_build_addr_expr (pchar_type_node,
4624 gfc_build_localized_cstring_const
4625 ("Integer overflow when calculating the amount of "
4626 "memory to allocate"));
4627 error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
4631 if (status != NULL_TREE)
4633 tree status_type = TREE_TYPE (status);
4634 stmtblock_t set_status_block;
4636 gfc_start_block (&set_status_block);
4637 gfc_add_modify (&set_status_block, status,
4638 build_int_cst (status_type, LIBERROR_ALLOCATION));
4639 error = gfc_finish_block (&set_status_block);
4642 gfc_start_block (&elseblock);
4644 /* Allocate memory to store the data. */
4645 pointer = gfc_conv_descriptor_data_get (se->expr);
4646 STRIP_NOPS (pointer);
4648 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
4649 token = gfc_build_addr_expr (NULL_TREE,
4650 gfc_conv_descriptor_token (se->expr));
4652 /* The allocatable variant takes the old pointer as first argument. */
4654 gfc_allocate_allocatable (&elseblock, pointer, size, token,
4655 status, errmsg, errlen, expr);
4657 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
4661 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
4662 boolean_type_node, var_overflow, integer_zero_node));
4663 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
4664 error, gfc_finish_block (&elseblock));
4667 tmp = gfc_finish_block (&elseblock);
4669 gfc_add_expr_to_block (&se->pre, tmp);
4671 /* Update the array descriptors. */
4673 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
4675 set_descriptor = gfc_finish_block (&set_descriptor_block);
4676 if (status != NULL_TREE)
4678 cond = fold_build2_loc (input_location, EQ_EXPR,
4679 boolean_type_node, status,
4680 build_int_cst (TREE_TYPE (status), 0));
4681 gfc_add_expr_to_block (&se->pre,
4682 fold_build3_loc (input_location, COND_EXPR, void_type_node,
4683 gfc_likely (cond), set_descriptor,
4684 build_empty_stmt (input_location)));
4687 gfc_add_expr_to_block (&se->pre, set_descriptor);
4689 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
4690 && expr->ts.u.derived->attr.alloc_comp)
4692 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
4693 ref->u.ar.as->rank);
4694 gfc_add_expr_to_block (&se->pre, tmp);
4701 /* Deallocate an array variable. Also used when an allocated variable goes
4706 gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
4712 gfc_start_block (&block);
4713 /* Get a pointer to the data. */
4714 var = gfc_conv_descriptor_data_get (descriptor);
4717 /* Parameter is the address of the data component. */
4718 tmp = gfc_deallocate_with_status (var, pstat, false, expr);
4719 gfc_add_expr_to_block (&block, tmp);
4721 /* Zero the data pointer. */
4722 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
4723 var, build_int_cst (TREE_TYPE (var), 0));
4724 gfc_add_expr_to_block (&block, tmp);
4726 return gfc_finish_block (&block);
4730 /* Create an array constructor from an initialization expression.
4731 We assume the frontend already did any expansions and conversions. */
4734 gfc_conv_array_initializer (tree type, gfc_expr * expr)
4740 unsigned HOST_WIDE_INT lo;
4742 VEC(constructor_elt,gc) *v = NULL;
4744 switch (expr->expr_type)
4747 case EXPR_STRUCTURE:
4748 /* A single scalar or derived type value. Create an array with all
4749 elements equal to that value. */
4750 gfc_init_se (&se, NULL);
4752 if (expr->expr_type == EXPR_CONSTANT)
4753 gfc_conv_constant (&se, expr);
4755 gfc_conv_structure (&se, expr, 1);
4757 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4758 gcc_assert (tmp && INTEGER_CST_P (tmp));
4759 hi = TREE_INT_CST_HIGH (tmp);
4760 lo = TREE_INT_CST_LOW (tmp);
4764 /* This will probably eat buckets of memory for large arrays. */
4765 while (hi != 0 || lo != 0)
4767 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
4775 /* Create a vector of all the elements. */
4776 for (c = gfc_constructor_first (expr->value.constructor);
4777 c; c = gfc_constructor_next (c))
4781 /* Problems occur when we get something like
4782 integer :: a(lots) = (/(i, i=1, lots)/) */
4783 gfc_fatal_error ("The number of elements in the array constructor "
4784 "at %L requires an increase of the allowed %d "
4785 "upper limit. See -fmax-array-constructor "
4786 "option", &expr->where,
4787 gfc_option.flag_max_array_constructor);
4790 if (mpz_cmp_si (c->offset, 0) != 0)
4791 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4795 if (mpz_cmp_si (c->repeat, 1) > 0)
4801 mpz_add (maxval, c->offset, c->repeat);
4802 mpz_sub_ui (maxval, maxval, 1);
4803 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4804 if (mpz_cmp_si (c->offset, 0) != 0)
4806 mpz_add_ui (maxval, c->offset, 1);
4807 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
4810 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
4812 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
4818 gfc_init_se (&se, NULL);
4819 switch (c->expr->expr_type)
4822 gfc_conv_constant (&se, c->expr);
4825 case EXPR_STRUCTURE:
4826 gfc_conv_structure (&se, c->expr, 1);
4830 /* Catch those occasional beasts that do not simplify
4831 for one reason or another, assuming that if they are
4832 standard defying the frontend will catch them. */
4833 gfc_conv_expr (&se, c->expr);
4837 if (range == NULL_TREE)
4838 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4841 if (index != NULL_TREE)
4842 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
4843 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
4849 return gfc_build_null_descriptor (type);
4855 /* Create a constructor from the list of elements. */
4856 tmp = build_constructor (type, v);
4857 TREE_CONSTANT (tmp) = 1;
4862 /* Generate code to evaluate non-constant coarray cobounds. */
4865 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
4866 const gfc_symbol *sym)
4876 for (dim = as->rank; dim < as->rank + as->corank; dim++)
4878 /* Evaluate non-constant array bound expressions. */
4879 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4880 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4882 gfc_init_se (&se, NULL);
4883 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4884 gfc_add_block_to_block (pblock, &se.pre);
4885 gfc_add_modify (pblock, lbound, se.expr);
4887 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4888 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4890 gfc_init_se (&se, NULL);
4891 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4892 gfc_add_block_to_block (pblock, &se.pre);
4893 gfc_add_modify (pblock, ubound, se.expr);
4899 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
4900 returns the size (in elements) of the array. */
4903 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
4904 stmtblock_t * pblock)
4919 size = gfc_index_one_node;
4920 offset = gfc_index_zero_node;
4921 for (dim = 0; dim < as->rank; dim++)
4923 /* Evaluate non-constant array bound expressions. */
4924 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
4925 if (as->lower[dim] && !INTEGER_CST_P (lbound))
4927 gfc_init_se (&se, NULL);
4928 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
4929 gfc_add_block_to_block (pblock, &se.pre);
4930 gfc_add_modify (pblock, lbound, se.expr);
4932 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
4933 if (as->upper[dim] && !INTEGER_CST_P (ubound))
4935 gfc_init_se (&se, NULL);
4936 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
4937 gfc_add_block_to_block (pblock, &se.pre);
4938 gfc_add_modify (pblock, ubound, se.expr);
4940 /* The offset of this dimension. offset = offset - lbound * stride. */
4941 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4943 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4946 /* The size of this dimension, and the stride of the next. */
4947 if (dim + 1 < as->rank)
4948 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
4950 stride = GFC_TYPE_ARRAY_SIZE (type);
4952 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
4954 /* Calculate stride = size * (ubound + 1 - lbound). */
4955 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4956 gfc_array_index_type,
4957 gfc_index_one_node, lbound);
4958 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4959 gfc_array_index_type, ubound, tmp);
4960 tmp = fold_build2_loc (input_location, MULT_EXPR,
4961 gfc_array_index_type, size, tmp);
4963 gfc_add_modify (pblock, stride, tmp);
4965 stride = gfc_evaluate_now (tmp, pblock);
4967 /* Make sure that negative size arrays are translated
4968 to being zero size. */
4969 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4970 stride, gfc_index_zero_node);
4971 tmp = fold_build3_loc (input_location, COND_EXPR,
4972 gfc_array_index_type, tmp,
4973 stride, gfc_index_zero_node);
4974 gfc_add_modify (pblock, stride, tmp);
4980 gfc_trans_array_cobounds (type, pblock, sym);
4981 gfc_trans_vla_type_sizes (sym, pblock);
4988 /* Generate code to initialize/allocate an array variable. */
4991 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
4992 gfc_wrapped_block * block)
4996 tree tmp = NULL_TREE;
5003 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5005 /* Do nothing for USEd variables. */
5006 if (sym->attr.use_assoc)
5009 type = TREE_TYPE (decl);
5010 gcc_assert (GFC_ARRAY_TYPE_P (type));
5011 onstack = TREE_CODE (type) != POINTER_TYPE;
5013 gfc_init_block (&init);
5015 /* Evaluate character string length. */
5016 if (sym->ts.type == BT_CHARACTER
5017 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5019 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5021 gfc_trans_vla_type_sizes (sym, &init);
5023 /* Emit a DECL_EXPR for this variable, which will cause the
5024 gimplifier to allocate storage, and all that good stuff. */
5025 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5026 gfc_add_expr_to_block (&init, tmp);
5031 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5035 type = TREE_TYPE (type);
5037 gcc_assert (!sym->attr.use_assoc);
5038 gcc_assert (!TREE_STATIC (decl));
5039 gcc_assert (!sym->module);
5041 if (sym->ts.type == BT_CHARACTER
5042 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5043 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5045 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5047 /* Don't actually allocate space for Cray Pointees. */
5048 if (sym->attr.cray_pointee)
5050 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5051 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5053 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5057 if (gfc_option.flag_stack_arrays)
5059 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5060 space = build_decl (sym->declared_at.lb->location,
5061 VAR_DECL, create_tmp_var_name ("A"),
5062 TREE_TYPE (TREE_TYPE (decl)));
5063 gfc_trans_vla_type_sizes (sym, &init);
5067 /* The size is the number of elements in the array, so multiply by the
5068 size of an element to get the total size. */
5069 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5070 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5071 size, fold_convert (gfc_array_index_type, tmp));
5073 /* Allocate memory to hold the data. */
5074 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5075 gfc_add_modify (&init, decl, tmp);
5077 /* Free the temporary. */
5078 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5082 /* Set offset of the array. */
5083 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5084 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5086 /* Automatic arrays should not have initializers. */
5087 gcc_assert (!sym->value);
5089 inittree = gfc_finish_block (&init);
5096 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5097 where also space is located. */
5098 gfc_init_block (&init);
5099 tmp = fold_build1_loc (input_location, DECL_EXPR,
5100 TREE_TYPE (space), space);
5101 gfc_add_expr_to_block (&init, tmp);
5102 addr = fold_build1_loc (sym->declared_at.lb->location,
5103 ADDR_EXPR, TREE_TYPE (decl), space);
5104 gfc_add_modify (&init, decl, addr);
5105 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5108 gfc_add_init_cleanup (block, inittree, tmp);
5112 /* Generate entry and exit code for g77 calling convention arrays. */
5115 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5125 gfc_save_backend_locus (&loc);
5126 gfc_set_backend_locus (&sym->declared_at);
5128 /* Descriptor type. */
5129 parm = sym->backend_decl;
5130 type = TREE_TYPE (parm);
5131 gcc_assert (GFC_ARRAY_TYPE_P (type));
5133 gfc_start_block (&init);
5135 if (sym->ts.type == BT_CHARACTER
5136 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5137 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5139 /* Evaluate the bounds of the array. */
5140 gfc_trans_array_bounds (type, sym, &offset, &init);
5142 /* Set the offset. */
5143 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5144 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5146 /* Set the pointer itself if we aren't using the parameter directly. */
5147 if (TREE_CODE (parm) != PARM_DECL)
5149 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5150 gfc_add_modify (&init, parm, tmp);
5152 stmt = gfc_finish_block (&init);
5154 gfc_restore_backend_locus (&loc);
5156 /* Add the initialization code to the start of the function. */
5158 if (sym->attr.optional || sym->attr.not_always_present)
5160 tmp = gfc_conv_expr_present (sym);
5161 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5164 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5168 /* Modify the descriptor of an array parameter so that it has the
5169 correct lower bound. Also move the upper bound accordingly.
5170 If the array is not packed, it will be copied into a temporary.
5171 For each dimension we set the new lower and upper bounds. Then we copy the
5172 stride and calculate the offset for this dimension. We also work out
5173 what the stride of a packed array would be, and see it the two match.
5174 If the array need repacking, we set the stride to the values we just
5175 calculated, recalculate the offset and copy the array data.
5176 Code is also added to copy the data back at the end of the function.
5180 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5181 gfc_wrapped_block * block)
5188 tree stmtInit, stmtCleanup;
5195 tree stride, stride2;
5205 /* Do nothing for pointer and allocatable arrays. */
5206 if (sym->attr.pointer || sym->attr.allocatable)
5209 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5211 gfc_trans_g77_array (sym, block);
5215 gfc_save_backend_locus (&loc);
5216 gfc_set_backend_locus (&sym->declared_at);
5218 /* Descriptor type. */
5219 type = TREE_TYPE (tmpdesc);
5220 gcc_assert (GFC_ARRAY_TYPE_P (type));
5221 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5222 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5223 gfc_start_block (&init);
5225 if (sym->ts.type == BT_CHARACTER
5226 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5227 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5229 checkparm = (sym->as->type == AS_EXPLICIT
5230 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5232 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5233 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5235 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5237 /* For non-constant shape arrays we only check if the first dimension
5238 is contiguous. Repacking higher dimensions wouldn't gain us
5239 anything as we still don't know the array stride. */
5240 partial = gfc_create_var (boolean_type_node, "partial");
5241 TREE_USED (partial) = 1;
5242 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5243 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5244 gfc_index_one_node);
5245 gfc_add_modify (&init, partial, tmp);
5248 partial = NULL_TREE;
5250 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5251 here, however I think it does the right thing. */
5254 /* Set the first stride. */
5255 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5256 stride = gfc_evaluate_now (stride, &init);
5258 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5259 stride, gfc_index_zero_node);
5260 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5261 tmp, gfc_index_one_node, stride);
5262 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5263 gfc_add_modify (&init, stride, tmp);
5265 /* Allow the user to disable array repacking. */
5266 stmt_unpacked = NULL_TREE;
5270 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5271 /* A library call to repack the array if necessary. */
5272 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5273 stmt_unpacked = build_call_expr_loc (input_location,
5274 gfor_fndecl_in_pack, 1, tmp);
5276 stride = gfc_index_one_node;
5278 if (gfc_option.warn_array_temp)
5279 gfc_warning ("Creating array temporary at %L", &loc);
5282 /* This is for the case where the array data is used directly without
5283 calling the repack function. */
5284 if (no_repack || partial != NULL_TREE)
5285 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5287 stmt_packed = NULL_TREE;
5289 /* Assign the data pointer. */
5290 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5292 /* Don't repack unknown shape arrays when the first stride is 1. */
5293 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5294 partial, stmt_packed, stmt_unpacked);
5297 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5298 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5300 offset = gfc_index_zero_node;
5301 size = gfc_index_one_node;
5303 /* Evaluate the bounds of the array. */
5304 for (n = 0; n < sym->as->rank; n++)
5306 if (checkparm || !sym->as->upper[n])
5308 /* Get the bounds of the actual parameter. */
5309 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5310 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5314 dubound = NULL_TREE;
5315 dlbound = NULL_TREE;
5318 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5319 if (!INTEGER_CST_P (lbound))
5321 gfc_init_se (&se, NULL);
5322 gfc_conv_expr_type (&se, sym->as->lower[n],
5323 gfc_array_index_type);
5324 gfc_add_block_to_block (&init, &se.pre);
5325 gfc_add_modify (&init, lbound, se.expr);
5328 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5329 /* Set the desired upper bound. */
5330 if (sym->as->upper[n])
5332 /* We know what we want the upper bound to be. */
5333 if (!INTEGER_CST_P (ubound))
5335 gfc_init_se (&se, NULL);
5336 gfc_conv_expr_type (&se, sym->as->upper[n],
5337 gfc_array_index_type);
5338 gfc_add_block_to_block (&init, &se.pre);
5339 gfc_add_modify (&init, ubound, se.expr);
5342 /* Check the sizes match. */
5345 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5349 temp = fold_build2_loc (input_location, MINUS_EXPR,
5350 gfc_array_index_type, ubound, lbound);
5351 temp = fold_build2_loc (input_location, PLUS_EXPR,
5352 gfc_array_index_type,
5353 gfc_index_one_node, temp);
5354 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5355 gfc_array_index_type, dubound,
5357 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5358 gfc_array_index_type,
5359 gfc_index_one_node, stride2);
5360 tmp = fold_build2_loc (input_location, NE_EXPR,
5361 gfc_array_index_type, temp, stride2);
5362 asprintf (&msg, "Dimension %d of array '%s' has extent "
5363 "%%ld instead of %%ld", n+1, sym->name);
5365 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
5366 fold_convert (long_integer_type_node, temp),
5367 fold_convert (long_integer_type_node, stride2));
5374 /* For assumed shape arrays move the upper bound by the same amount
5375 as the lower bound. */
5376 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5377 gfc_array_index_type, dubound, dlbound);
5378 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5379 gfc_array_index_type, tmp, lbound);
5380 gfc_add_modify (&init, ubound, tmp);
5382 /* The offset of this dimension. offset = offset - lbound * stride. */
5383 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5385 offset = fold_build2_loc (input_location, MINUS_EXPR,
5386 gfc_array_index_type, offset, tmp);
5388 /* The size of this dimension, and the stride of the next. */
5389 if (n + 1 < sym->as->rank)
5391 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
5393 if (no_repack || partial != NULL_TREE)
5395 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
5397 /* Figure out the stride if not a known constant. */
5398 if (!INTEGER_CST_P (stride))
5401 stmt_packed = NULL_TREE;
5404 /* Calculate stride = size * (ubound + 1 - lbound). */
5405 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5406 gfc_array_index_type,
5407 gfc_index_one_node, lbound);
5408 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5409 gfc_array_index_type, ubound, tmp);
5410 size = fold_build2_loc (input_location, MULT_EXPR,
5411 gfc_array_index_type, size, tmp);
5415 /* Assign the stride. */
5416 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5417 tmp = fold_build3_loc (input_location, COND_EXPR,
5418 gfc_array_index_type, partial,
5419 stmt_unpacked, stmt_packed);
5421 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
5422 gfc_add_modify (&init, stride, tmp);
5427 stride = GFC_TYPE_ARRAY_SIZE (type);
5429 if (stride && !INTEGER_CST_P (stride))
5431 /* Calculate size = stride * (ubound + 1 - lbound). */
5432 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5433 gfc_array_index_type,
5434 gfc_index_one_node, lbound);
5435 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5436 gfc_array_index_type,
5438 tmp = fold_build2_loc (input_location, MULT_EXPR,
5439 gfc_array_index_type,
5440 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
5441 gfc_add_modify (&init, stride, tmp);
5446 gfc_trans_array_cobounds (type, &init, sym);
5448 /* Set the offset. */
5449 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5450 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5452 gfc_trans_vla_type_sizes (sym, &init);
5454 stmtInit = gfc_finish_block (&init);
5456 /* Only do the entry/initialization code if the arg is present. */
5457 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5458 optional_arg = (sym->attr.optional
5459 || (sym->ns->proc_name->attr.entry_master
5460 && sym->attr.dummy));
5463 tmp = gfc_conv_expr_present (sym);
5464 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
5465 build_empty_stmt (input_location));
5470 stmtCleanup = NULL_TREE;
5473 stmtblock_t cleanup;
5474 gfc_start_block (&cleanup);
5476 if (sym->attr.intent != INTENT_IN)
5478 /* Copy the data back. */
5479 tmp = build_call_expr_loc (input_location,
5480 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
5481 gfc_add_expr_to_block (&cleanup, tmp);
5484 /* Free the temporary. */
5485 tmp = gfc_call_free (tmpdesc);
5486 gfc_add_expr_to_block (&cleanup, tmp);
5488 stmtCleanup = gfc_finish_block (&cleanup);
5490 /* Only do the cleanup if the array was repacked. */
5491 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
5492 tmp = gfc_conv_descriptor_data_get (tmp);
5493 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5495 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5496 build_empty_stmt (input_location));
5500 tmp = gfc_conv_expr_present (sym);
5501 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
5502 build_empty_stmt (input_location));
5506 /* We don't need to free any memory allocated by internal_pack as it will
5507 be freed at the end of the function by pop_context. */
5508 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
5510 gfc_restore_backend_locus (&loc);
5514 /* Calculate the overall offset, including subreferences. */
5516 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
5517 bool subref, gfc_expr *expr)
5527 /* If offset is NULL and this is not a subreferenced array, there is
5529 if (offset == NULL_TREE)
5532 offset = gfc_index_zero_node;
5537 tmp = gfc_conv_array_data (desc);
5538 tmp = build_fold_indirect_ref_loc (input_location,
5540 tmp = gfc_build_array_ref (tmp, offset, NULL);
5542 /* Offset the data pointer for pointer assignments from arrays with
5543 subreferences; e.g. my_integer => my_type(:)%integer_component. */
5546 /* Go past the array reference. */
5547 for (ref = expr->ref; ref; ref = ref->next)
5548 if (ref->type == REF_ARRAY &&
5549 ref->u.ar.type != AR_ELEMENT)
5555 /* Calculate the offset for each subsequent subreference. */
5556 for (; ref; ref = ref->next)
5561 field = ref->u.c.component->backend_decl;
5562 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
5563 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5565 tmp, field, NULL_TREE);
5569 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
5570 gfc_init_se (&start, NULL);
5571 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
5572 gfc_add_block_to_block (block, &start.pre);
5573 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
5577 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
5578 && ref->u.ar.type == AR_ELEMENT);
5580 /* TODO - Add bounds checking. */
5581 stride = gfc_index_one_node;
5582 index = gfc_index_zero_node;
5583 for (n = 0; n < ref->u.ar.dimen; n++)
5588 /* Update the index. */
5589 gfc_init_se (&start, NULL);
5590 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
5591 itmp = gfc_evaluate_now (start.expr, block);
5592 gfc_init_se (&start, NULL);
5593 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
5594 jtmp = gfc_evaluate_now (start.expr, block);
5595 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5596 gfc_array_index_type, itmp, jtmp);
5597 itmp = fold_build2_loc (input_location, MULT_EXPR,
5598 gfc_array_index_type, itmp, stride);
5599 index = fold_build2_loc (input_location, PLUS_EXPR,
5600 gfc_array_index_type, itmp, index);
5601 index = gfc_evaluate_now (index, block);
5603 /* Update the stride. */
5604 gfc_init_se (&start, NULL);
5605 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
5606 itmp = fold_build2_loc (input_location, MINUS_EXPR,
5607 gfc_array_index_type, start.expr,
5609 itmp = fold_build2_loc (input_location, PLUS_EXPR,
5610 gfc_array_index_type,
5611 gfc_index_one_node, itmp);
5612 stride = fold_build2_loc (input_location, MULT_EXPR,
5613 gfc_array_index_type, stride, itmp);
5614 stride = gfc_evaluate_now (stride, block);
5617 /* Apply the index to obtain the array element. */
5618 tmp = gfc_build_array_ref (tmp, index, NULL);
5628 /* Set the target data pointer. */
5629 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
5630 gfc_conv_descriptor_data_set (block, parm, offset);
5634 /* gfc_conv_expr_descriptor needs the string length an expression
5635 so that the size of the temporary can be obtained. This is done
5636 by adding up the string lengths of all the elements in the
5637 expression. Function with non-constant expressions have their
5638 string lengths mapped onto the actual arguments using the
5639 interface mapping machinery in trans-expr.c. */
5641 get_array_charlen (gfc_expr *expr, gfc_se *se)
5643 gfc_interface_mapping mapping;
5644 gfc_formal_arglist *formal;
5645 gfc_actual_arglist *arg;
5648 if (expr->ts.u.cl->length
5649 && gfc_is_constant_expr (expr->ts.u.cl->length))
5651 if (!expr->ts.u.cl->backend_decl)
5652 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5656 switch (expr->expr_type)
5659 get_array_charlen (expr->value.op.op1, se);
5661 /* For parentheses the expression ts.u.cl is identical. */
5662 if (expr->value.op.op == INTRINSIC_PARENTHESES)
5665 expr->ts.u.cl->backend_decl =
5666 gfc_create_var (gfc_charlen_type_node, "sln");
5668 if (expr->value.op.op2)
5670 get_array_charlen (expr->value.op.op2, se);
5672 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
5674 /* Add the string lengths and assign them to the expression
5675 string length backend declaration. */
5676 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5677 fold_build2_loc (input_location, PLUS_EXPR,
5678 gfc_charlen_type_node,
5679 expr->value.op.op1->ts.u.cl->backend_decl,
5680 expr->value.op.op2->ts.u.cl->backend_decl));
5683 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
5684 expr->value.op.op1->ts.u.cl->backend_decl);
5688 if (expr->value.function.esym == NULL
5689 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5691 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5695 /* Map expressions involving the dummy arguments onto the actual
5696 argument expressions. */
5697 gfc_init_interface_mapping (&mapping);
5698 formal = expr->symtree->n.sym->formal;
5699 arg = expr->value.function.actual;
5701 /* Set se = NULL in the calls to the interface mapping, to suppress any
5703 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
5708 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
5711 gfc_init_se (&tse, NULL);
5713 /* Build the expression for the character length and convert it. */
5714 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
5716 gfc_add_block_to_block (&se->pre, &tse.pre);
5717 gfc_add_block_to_block (&se->post, &tse.post);
5718 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
5719 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
5720 gfc_charlen_type_node, tse.expr,
5721 build_int_cst (gfc_charlen_type_node, 0));
5722 expr->ts.u.cl->backend_decl = tse.expr;
5723 gfc_free_interface_mapping (&mapping);
5727 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
5733 /* Helper function to check dimensions. */
5735 transposed_dims (gfc_ss *ss)
5739 for (n = 0; n < ss->dimen; n++)
5740 if (ss->dim[n] != n)
5745 /* Convert an array for passing as an actual argument. Expressions and
5746 vector subscripts are evaluated and stored in a temporary, which is then
5747 passed. For whole arrays the descriptor is passed. For array sections
5748 a modified copy of the descriptor is passed, but using the original data.
5750 This function is also used for array pointer assignments, and there
5753 - se->want_pointer && !se->direct_byref
5754 EXPR is an actual argument. On exit, se->expr contains a
5755 pointer to the array descriptor.
5757 - !se->want_pointer && !se->direct_byref
5758 EXPR is an actual argument to an intrinsic function or the
5759 left-hand side of a pointer assignment. On exit, se->expr
5760 contains the descriptor for EXPR.
5762 - !se->want_pointer && se->direct_byref
5763 EXPR is the right-hand side of a pointer assignment and
5764 se->expr is the descriptor for the previously-evaluated
5765 left-hand side. The function creates an assignment from
5769 The se->force_tmp flag disables the non-copying descriptor optimization
5770 that is used for transpose. It may be used in cases where there is an
5771 alias between the transpose argument and another argument in the same
5775 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
5777 gfc_ss_type ss_type;
5778 gfc_ss_info *ss_info;
5780 gfc_array_info *info;
5789 bool subref_array_target = false;
5790 gfc_expr *arg, *ss_expr;
5792 gcc_assert (ss != NULL);
5793 gcc_assert (ss != gfc_ss_terminator);
5796 ss_type = ss_info->type;
5797 ss_expr = ss_info->expr;
5799 /* Special case things we know we can pass easily. */
5800 switch (expr->expr_type)
5803 /* If we have a linear array section, we can pass it directly.
5804 Otherwise we need to copy it into a temporary. */
5806 gcc_assert (ss_type == GFC_SS_SECTION);
5807 gcc_assert (ss_expr == expr);
5808 info = &ss->data.info;
5810 /* Get the descriptor for the array. */
5811 gfc_conv_ss_descriptor (&se->pre, ss, 0);
5812 desc = info->descriptor;
5814 subref_array_target = se->direct_byref && is_subref_array (expr);
5815 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
5816 && !subref_array_target;
5823 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
5825 /* Create a new descriptor if the array doesn't have one. */
5828 else if (info->ref->u.ar.type == AR_FULL)
5830 else if (se->direct_byref)
5833 full = gfc_full_array_ref_p (info->ref, NULL);
5835 if (full && !transposed_dims (ss))
5837 if (se->direct_byref && !se->byref_noassign)
5839 /* Copy the descriptor for pointer assignments. */
5840 gfc_add_modify (&se->pre, se->expr, desc);
5842 /* Add any offsets from subreferences. */
5843 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
5844 subref_array_target, expr);
5846 else if (se->want_pointer)
5848 /* We pass full arrays directly. This means that pointers and
5849 allocatable arrays should also work. */
5850 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
5857 if (expr->ts.type == BT_CHARACTER)
5858 se->string_length = gfc_get_expr_charlen (expr);
5866 /* We don't need to copy data in some cases. */
5867 arg = gfc_get_noncopying_intrinsic_argument (expr);
5870 /* This is a call to transpose... */
5871 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
5872 /* ... which has already been handled by the scalarizer, so
5873 that we just need to get its argument's descriptor. */
5874 gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
5878 /* A transformational function return value will be a temporary
5879 array descriptor. We still need to go through the scalarizer
5880 to create the descriptor. Elemental functions ar handled as
5881 arbitrary expressions, i.e. copy to a temporary. */
5883 if (se->direct_byref)
5885 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
5887 /* For pointer assignments pass the descriptor directly. */
5891 gcc_assert (se->ss == ss);
5892 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
5893 gfc_conv_expr (se, expr);
5897 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
5899 if (ss_expr != expr)
5900 /* Elemental function. */
5901 gcc_assert ((expr->value.function.esym != NULL
5902 && expr->value.function.esym->attr.elemental)
5903 || (expr->value.function.isym != NULL
5904 && expr->value.function.isym->elemental));
5906 gcc_assert (ss_type == GFC_SS_INTRINSIC);
5909 if (expr->ts.type == BT_CHARACTER
5910 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5911 get_array_charlen (expr, se);
5917 /* Transformational function. */
5918 info = &ss->data.info;
5924 /* Constant array constructors don't need a temporary. */
5925 if (ss_type == GFC_SS_CONSTRUCTOR
5926 && expr->ts.type != BT_CHARACTER
5927 && gfc_constant_array_constructor_p (expr->value.constructor))
5930 info = &ss->data.info;
5940 /* Something complicated. Copy it into a temporary. */
5946 /* If we are creating a temporary, we don't need to bother about aliases
5951 gfc_init_loopinfo (&loop);
5953 /* Associate the SS with the loop. */
5954 gfc_add_ss_to_loop (&loop, ss);
5956 /* Tell the scalarizer not to bother creating loop variables, etc. */
5958 loop.array_parameter = 1;
5960 /* The right-hand side of a pointer assignment mustn't use a temporary. */
5961 gcc_assert (!se->direct_byref);
5963 /* Setup the scalarizing loops and bounds. */
5964 gfc_conv_ss_startstride (&loop);
5968 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5969 get_array_charlen (expr, se);
5971 /* Tell the scalarizer to make a temporary. */
5972 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
5973 ((expr->ts.type == BT_CHARACTER)
5974 ? expr->ts.u.cl->backend_decl
5978 se->string_length = loop.temp_ss->info->string_length;
5979 gcc_assert (loop.temp_ss->dimen == loop.dimen);
5980 gfc_add_ss_to_loop (&loop, loop.temp_ss);
5983 gfc_conv_loop_setup (&loop, & expr->where);
5987 /* Copy into a temporary and pass that. We don't need to copy the data
5988 back because expressions and vector subscripts must be INTENT_IN. */
5989 /* TODO: Optimize passing function return values. */
5993 /* Start the copying loops. */
5994 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5995 gfc_mark_ss_chain_used (ss, 1);
5996 gfc_start_scalarized_body (&loop, &block);
5998 /* Copy each data element. */
5999 gfc_init_se (&lse, NULL);
6000 gfc_copy_loopinfo_to_se (&lse, &loop);
6001 gfc_init_se (&rse, NULL);
6002 gfc_copy_loopinfo_to_se (&rse, &loop);
6004 lse.ss = loop.temp_ss;
6007 gfc_conv_scalarized_array_ref (&lse, NULL);
6008 if (expr->ts.type == BT_CHARACTER)
6010 gfc_conv_expr (&rse, expr);
6011 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6012 rse.expr = build_fold_indirect_ref_loc (input_location,
6016 gfc_conv_expr_val (&rse, expr);
6018 gfc_add_block_to_block (&block, &rse.pre);
6019 gfc_add_block_to_block (&block, &lse.pre);
6021 lse.string_length = rse.string_length;
6022 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6023 expr->expr_type == EXPR_VARIABLE
6024 || expr->expr_type == EXPR_ARRAY, true);
6025 gfc_add_expr_to_block (&block, tmp);
6027 /* Finish the copying loops. */
6028 gfc_trans_scalarizing_loops (&loop, &block);
6030 desc = loop.temp_ss->data.info.descriptor;
6032 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6034 desc = info->descriptor;
6035 se->string_length = ss_info->string_length;
6039 /* We pass sections without copying to a temporary. Make a new
6040 descriptor and point it at the section we want. The loop variable
6041 limits will be the limits of the section.
6042 A function may decide to repack the array to speed up access, but
6043 we're not bothered about that here. */
6044 int dim, ndim, codim;
6052 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6054 if (se->want_coarray)
6056 gfc_array_ref *ar = &info->ref->u.ar;
6058 codim = gfc_get_corank (expr);
6059 for (n = 0; n < codim - 1; n++)
6061 /* Make sure we are not lost somehow. */
6062 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6064 /* Make sure the call to gfc_conv_section_startstride won't
6065 generate unnecessary code to calculate stride. */
6066 gcc_assert (ar->stride[n + ndim] == NULL);
6068 gfc_conv_section_startstride (&loop, ss, n + ndim);
6069 loop.from[n + loop.dimen] = info->start[n + ndim];
6070 loop.to[n + loop.dimen] = info->end[n + ndim];
6073 gcc_assert (n == codim - 1);
6074 evaluate_bound (&loop.pre, info->start, ar->start,
6075 info->descriptor, n + ndim, true);
6076 loop.from[n + loop.dimen] = info->start[n + ndim];
6081 /* Set the string_length for a character array. */
6082 if (expr->ts.type == BT_CHARACTER)
6083 se->string_length = gfc_get_expr_charlen (expr);
6085 desc = info->descriptor;
6086 if (se->direct_byref && !se->byref_noassign)
6088 /* For pointer assignments we fill in the destination. */
6090 parmtype = TREE_TYPE (parm);
6094 /* Otherwise make a new one. */
6095 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6096 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6097 loop.from, loop.to, 0,
6098 GFC_ARRAY_UNKNOWN, false);
6099 parm = gfc_create_var (parmtype, "parm");
6102 offset = gfc_index_zero_node;
6104 /* The following can be somewhat confusing. We have two
6105 descriptors, a new one and the original array.
6106 {parm, parmtype, dim} refer to the new one.
6107 {desc, type, n, loop} refer to the original, which maybe
6108 a descriptorless array.
6109 The bounds of the scalarization are the bounds of the section.
6110 We don't have to worry about numeric overflows when calculating
6111 the offsets because all elements are within the array data. */
6113 /* Set the dtype. */
6114 tmp = gfc_conv_descriptor_dtype (parm);
6115 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6117 /* Set offset for assignments to pointer only to zero if it is not
6119 if (se->direct_byref
6120 && info->ref && info->ref->u.ar.type != AR_FULL)
6121 base = gfc_index_zero_node;
6122 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6123 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6127 for (n = 0; n < ndim; n++)
6129 stride = gfc_conv_array_stride (desc, n);
6131 /* Work out the offset. */
6133 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6135 gcc_assert (info->subscript[n]
6136 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6137 start = info->subscript[n]->data.scalar.expr;
6141 /* Evaluate and remember the start of the section. */
6142 start = info->start[n];
6143 stride = gfc_evaluate_now (stride, &loop.pre);
6146 tmp = gfc_conv_array_lbound (desc, n);
6147 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6149 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6151 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6155 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6157 /* For elemental dimensions, we only need the offset. */
6161 /* Vector subscripts need copying and are handled elsewhere. */
6163 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6165 /* look for the corresponding scalarizer dimension: dim. */
6166 for (dim = 0; dim < ndim; dim++)
6167 if (ss->dim[dim] == n)
6170 /* loop exited early: the DIM being looked for has been found. */
6171 gcc_assert (dim < ndim);
6173 /* Set the new lower bound. */
6174 from = loop.from[dim];
6177 /* If we have an array section or are assigning make sure that
6178 the lower bound is 1. References to the full
6179 array should otherwise keep the original bounds. */
6181 || info->ref->u.ar.type != AR_FULL)
6182 && !integer_onep (from))
6184 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6185 gfc_array_index_type, gfc_index_one_node,
6187 to = fold_build2_loc (input_location, PLUS_EXPR,
6188 gfc_array_index_type, to, tmp);
6189 from = gfc_index_one_node;
6191 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6192 gfc_rank_cst[dim], from);
6194 /* Set the new upper bound. */
6195 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6196 gfc_rank_cst[dim], to);
6198 /* Multiply the stride by the section stride to get the
6200 stride = fold_build2_loc (input_location, MULT_EXPR,
6201 gfc_array_index_type,
6202 stride, info->stride[n]);
6204 if (se->direct_byref
6206 && info->ref->u.ar.type != AR_FULL)
6208 base = fold_build2_loc (input_location, MINUS_EXPR,
6209 TREE_TYPE (base), base, stride);
6211 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6213 tmp = gfc_conv_array_lbound (desc, n);
6214 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6215 TREE_TYPE (base), tmp, loop.from[dim]);
6216 tmp = fold_build2_loc (input_location, MULT_EXPR,
6217 TREE_TYPE (base), tmp,
6218 gfc_conv_array_stride (desc, n));
6219 base = fold_build2_loc (input_location, PLUS_EXPR,
6220 TREE_TYPE (base), tmp, base);
6223 /* Store the new stride. */
6224 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6225 gfc_rank_cst[dim], stride);
6228 for (n = loop.dimen; n < loop.dimen + codim; n++)
6230 from = loop.from[n];
6232 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6233 gfc_rank_cst[n], from);
6234 if (n < loop.dimen + codim - 1)
6235 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6236 gfc_rank_cst[n], to);
6239 if (se->data_not_needed)
6240 gfc_conv_descriptor_data_set (&loop.pre, parm,
6241 gfc_index_zero_node);
6243 /* Point the data pointer at the 1st element in the section. */
6244 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6245 subref_array_target, expr);
6247 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6248 && !se->data_not_needed)
6250 /* Set the offset. */
6251 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6255 /* Only the callee knows what the correct offset it, so just set
6257 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6262 if (!se->direct_byref || se->byref_noassign)
6264 /* Get a pointer to the new descriptor. */
6265 if (se->want_pointer)
6266 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6271 gfc_add_block_to_block (&se->pre, &loop.pre);
6272 gfc_add_block_to_block (&se->post, &loop.post);
6274 /* Cleanup the scalarizer. */
6275 gfc_cleanup_loop (&loop);
6278 /* Helper function for gfc_conv_array_parameter if array size needs to be
6282 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6285 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6286 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6287 else if (expr->rank > 1)
6288 *size = build_call_expr_loc (input_location,
6289 gfor_fndecl_size0, 1,
6290 gfc_build_addr_expr (NULL, desc));
6293 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6294 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6296 *size = fold_build2_loc (input_location, MINUS_EXPR,
6297 gfc_array_index_type, ubound, lbound);
6298 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6299 *size, gfc_index_one_node);
6300 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6301 *size, gfc_index_zero_node);
6303 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6304 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6305 *size, fold_convert (gfc_array_index_type, elem));
6308 /* Convert an array for passing as an actual parameter. */
6309 /* TODO: Optimize passing g77 arrays. */
6312 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
6313 const gfc_symbol *fsym, const char *proc_name,
6318 tree tmp = NULL_TREE;
6320 tree parent = DECL_CONTEXT (current_function_decl);
6321 bool full_array_var;
6322 bool this_array_result;
6325 bool array_constructor;
6326 bool good_allocatable;
6327 bool ultimate_ptr_comp;
6328 bool ultimate_alloc_comp;
6333 ultimate_ptr_comp = false;
6334 ultimate_alloc_comp = false;
6336 for (ref = expr->ref; ref; ref = ref->next)
6338 if (ref->next == NULL)
6341 if (ref->type == REF_COMPONENT)
6343 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
6344 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
6348 full_array_var = false;
6351 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
6352 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
6354 sym = full_array_var ? expr->symtree->n.sym : NULL;
6356 /* The symbol should have an array specification. */
6357 gcc_assert (!sym || sym->as || ref->u.ar.as);
6359 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
6361 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
6362 expr->ts.u.cl->backend_decl = tmp;
6363 se->string_length = tmp;
6366 /* Is this the result of the enclosing procedure? */
6367 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
6368 if (this_array_result
6369 && (sym->backend_decl != current_function_decl)
6370 && (sym->backend_decl != parent))
6371 this_array_result = false;
6373 /* Passing address of the array if it is not pointer or assumed-shape. */
6374 if (full_array_var && g77 && !this_array_result)
6376 tmp = gfc_get_symbol_decl (sym);
6378 if (sym->ts.type == BT_CHARACTER)
6379 se->string_length = sym->ts.u.cl->backend_decl;
6381 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
6383 gfc_conv_expr_descriptor (se, expr, ss);
6384 se->expr = gfc_conv_array_data (se->expr);
6388 if (!sym->attr.pointer
6390 && sym->as->type != AS_ASSUMED_SHAPE
6391 && !sym->attr.allocatable)
6393 /* Some variables are declared directly, others are declared as
6394 pointers and allocated on the heap. */
6395 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
6398 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6400 array_parameter_size (tmp, expr, size);
6404 if (sym->attr.allocatable)
6406 if (sym->attr.dummy || sym->attr.result)
6408 gfc_conv_expr_descriptor (se, expr, ss);
6412 array_parameter_size (tmp, expr, size);
6413 se->expr = gfc_conv_array_data (tmp);
6418 /* A convenient reduction in scope. */
6419 contiguous = g77 && !this_array_result && contiguous;
6421 /* There is no need to pack and unpack the array, if it is contiguous
6422 and not a deferred- or assumed-shape array, or if it is simply
6424 no_pack = ((sym && sym->as
6425 && !sym->attr.pointer
6426 && sym->as->type != AS_DEFERRED
6427 && sym->as->type != AS_ASSUMED_SHAPE)
6429 (ref && ref->u.ar.as
6430 && ref->u.ar.as->type != AS_DEFERRED
6431 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
6433 gfc_is_simply_contiguous (expr, false));
6435 no_pack = contiguous && no_pack;
6437 /* Array constructors are always contiguous and do not need packing. */
6438 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
6440 /* Same is true of contiguous sections from allocatable variables. */
6441 good_allocatable = contiguous
6443 && expr->symtree->n.sym->attr.allocatable;
6445 /* Or ultimate allocatable components. */
6446 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
6448 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
6450 gfc_conv_expr_descriptor (se, expr, ss);
6451 if (expr->ts.type == BT_CHARACTER)
6452 se->string_length = expr->ts.u.cl->backend_decl;
6454 array_parameter_size (se->expr, expr, size);
6455 se->expr = gfc_conv_array_data (se->expr);
6459 if (this_array_result)
6461 /* Result of the enclosing function. */
6462 gfc_conv_expr_descriptor (se, expr, ss);
6464 array_parameter_size (se->expr, expr, size);
6465 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6467 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
6468 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
6469 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
6476 /* Every other type of array. */
6477 se->want_pointer = 1;
6478 gfc_conv_expr_descriptor (se, expr, ss);
6480 array_parameter_size (build_fold_indirect_ref_loc (input_location,
6485 /* Deallocate the allocatable components of structures that are
6487 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
6488 && expr->ts.u.derived->attr.alloc_comp
6489 && expr->expr_type != EXPR_VARIABLE)
6491 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
6492 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
6494 /* The components shall be deallocated before their containing entity. */
6495 gfc_prepend_expr_to_block (&se->post, tmp);
6498 if (g77 || (fsym && fsym->attr.contiguous
6499 && !gfc_is_simply_contiguous (expr, false)))
6501 tree origptr = NULL_TREE;
6505 /* For contiguous arrays, save the original value of the descriptor. */
6508 origptr = gfc_create_var (pvoid_type_node, "origptr");
6509 tmp = build_fold_indirect_ref_loc (input_location, desc);
6510 tmp = gfc_conv_array_data (tmp);
6511 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6512 TREE_TYPE (origptr), origptr,
6513 fold_convert (TREE_TYPE (origptr), tmp));
6514 gfc_add_expr_to_block (&se->pre, tmp);
6517 /* Repack the array. */
6518 if (gfc_option.warn_array_temp)
6521 gfc_warning ("Creating array temporary at %L for argument '%s'",
6522 &expr->where, fsym->name);
6524 gfc_warning ("Creating array temporary at %L", &expr->where);
6527 ptr = build_call_expr_loc (input_location,
6528 gfor_fndecl_in_pack, 1, desc);
6530 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6532 tmp = gfc_conv_expr_present (sym);
6533 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
6534 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
6535 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
6538 ptr = gfc_evaluate_now (ptr, &se->pre);
6540 /* Use the packed data for the actual argument, except for contiguous arrays,
6541 where the descriptor's data component is set. */
6546 tmp = build_fold_indirect_ref_loc (input_location, desc);
6547 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
6550 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
6554 if (fsym && proc_name)
6555 asprintf (&msg, "An array temporary was created for argument "
6556 "'%s' of procedure '%s'", fsym->name, proc_name);
6558 asprintf (&msg, "An array temporary was created");
6560 tmp = build_fold_indirect_ref_loc (input_location,
6562 tmp = gfc_conv_array_data (tmp);
6563 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6564 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6566 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6567 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6569 gfc_conv_expr_present (sym), tmp);
6571 gfc_trans_runtime_check (false, true, tmp, &se->pre,
6576 gfc_start_block (&block);
6578 /* Copy the data back. */
6579 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
6581 tmp = build_call_expr_loc (input_location,
6582 gfor_fndecl_in_unpack, 2, desc, ptr);
6583 gfc_add_expr_to_block (&block, tmp);
6586 /* Free the temporary. */
6587 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
6588 gfc_add_expr_to_block (&block, tmp);
6590 stmt = gfc_finish_block (&block);
6592 gfc_init_block (&block);
6593 /* Only if it was repacked. This code needs to be executed before the
6594 loop cleanup code. */
6595 tmp = build_fold_indirect_ref_loc (input_location,
6597 tmp = gfc_conv_array_data (tmp);
6598 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6599 fold_convert (TREE_TYPE (tmp), ptr), tmp);
6601 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
6602 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6604 gfc_conv_expr_present (sym), tmp);
6606 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
6608 gfc_add_expr_to_block (&block, tmp);
6609 gfc_add_block_to_block (&block, &se->post);
6611 gfc_init_block (&se->post);
6613 /* Reset the descriptor pointer. */
6616 tmp = build_fold_indirect_ref_loc (input_location, desc);
6617 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
6620 gfc_add_block_to_block (&se->post, &block);
6625 /* Generate code to deallocate an array, if it is allocated. */
6628 gfc_trans_dealloc_allocated (tree descriptor)
6634 gfc_start_block (&block);
6636 var = gfc_conv_descriptor_data_get (descriptor);
6639 /* Call array_deallocate with an int * present in the second argument.
6640 Although it is ignored here, it's presence ensures that arrays that
6641 are already deallocated are ignored. */
6642 tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
6643 gfc_add_expr_to_block (&block, tmp);
6645 /* Zero the data pointer. */
6646 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6647 var, build_int_cst (TREE_TYPE (var), 0));
6648 gfc_add_expr_to_block (&block, tmp);
6650 return gfc_finish_block (&block);
6654 /* This helper function calculates the size in words of a full array. */
6657 get_full_array_size (stmtblock_t *block, tree decl, int rank)
6662 idx = gfc_rank_cst[rank - 1];
6663 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
6664 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
6665 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6667 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6668 tmp, gfc_index_one_node);
6669 tmp = gfc_evaluate_now (tmp, block);
6671 nelems = gfc_conv_descriptor_stride_get (decl, idx);
6672 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6674 return gfc_evaluate_now (tmp, block);
6678 /* Allocate dest to the same size as src, and copy src -> dest.
6679 If no_malloc is set, only the copy is done. */
6682 duplicate_allocatable (tree dest, tree src, tree type, int rank,
6692 /* If the source is null, set the destination to null. Then,
6693 allocate memory to the destination. */
6694 gfc_init_block (&block);
6698 tmp = null_pointer_node;
6699 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
6700 gfc_add_expr_to_block (&block, tmp);
6701 null_data = gfc_finish_block (&block);
6703 gfc_init_block (&block);
6704 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
6707 tmp = gfc_call_malloc (&block, type, size);
6708 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6709 dest, fold_convert (type, tmp));
6710 gfc_add_expr_to_block (&block, tmp);
6713 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6714 tmp = build_call_expr_loc (input_location, tmp, 3,
6719 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
6720 null_data = gfc_finish_block (&block);
6722 gfc_init_block (&block);
6723 nelems = get_full_array_size (&block, src, rank);
6724 tmp = fold_convert (gfc_array_index_type,
6725 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6726 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6730 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
6731 tmp = gfc_call_malloc (&block, tmp, size);
6732 gfc_conv_descriptor_data_set (&block, dest, tmp);
6735 /* We know the temporary and the value will be the same length,
6736 so can use memcpy. */
6737 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
6738 tmp = build_call_expr_loc (input_location,
6739 tmp, 3, gfc_conv_descriptor_data_get (dest),
6740 gfc_conv_descriptor_data_get (src), size);
6743 gfc_add_expr_to_block (&block, tmp);
6744 tmp = gfc_finish_block (&block);
6746 /* Null the destination if the source is null; otherwise do
6747 the allocate and copy. */
6751 null_cond = gfc_conv_descriptor_data_get (src);
6753 null_cond = convert (pvoid_type_node, null_cond);
6754 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6755 null_cond, null_pointer_node);
6756 return build3_v (COND_EXPR, null_cond, tmp, null_data);
6760 /* Allocate dest to the same size as src, and copy data src -> dest. */
6763 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
6765 return duplicate_allocatable (dest, src, type, rank, false);
6769 /* Copy data src -> dest. */
6772 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
6774 return duplicate_allocatable (dest, src, type, rank, true);
6778 /* Recursively traverse an object of derived type, generating code to
6779 deallocate, nullify or copy allocatable components. This is the work horse
6780 function for the functions named in this enum. */
6782 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
6783 COPY_ONLY_ALLOC_COMP};
6786 structure_alloc_comps (gfc_symbol * der_type, tree decl,
6787 tree dest, int rank, int purpose)
6791 stmtblock_t fnblock;
6792 stmtblock_t loopbody;
6803 tree null_cond = NULL_TREE;
6805 gfc_init_block (&fnblock);
6807 decl_type = TREE_TYPE (decl);
6809 if ((POINTER_TYPE_P (decl_type) && rank != 0)
6810 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
6812 decl = build_fold_indirect_ref_loc (input_location,
6815 /* Just in case in gets dereferenced. */
6816 decl_type = TREE_TYPE (decl);
6818 /* If this an array of derived types with allocatable components
6819 build a loop and recursively call this function. */
6820 if (TREE_CODE (decl_type) == ARRAY_TYPE
6821 || GFC_DESCRIPTOR_TYPE_P (decl_type))
6823 tmp = gfc_conv_array_data (decl);
6824 var = build_fold_indirect_ref_loc (input_location,
6827 /* Get the number of elements - 1 and set the counter. */
6828 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
6830 /* Use the descriptor for an allocatable array. Since this
6831 is a full array reference, we only need the descriptor
6832 information from dimension = rank. */
6833 tmp = get_full_array_size (&fnblock, decl, rank);
6834 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6835 gfc_array_index_type, tmp,
6836 gfc_index_one_node);
6838 null_cond = gfc_conv_descriptor_data_get (decl);
6839 null_cond = fold_build2_loc (input_location, NE_EXPR,
6840 boolean_type_node, null_cond,
6841 build_int_cst (TREE_TYPE (null_cond), 0));
6845 /* Otherwise use the TYPE_DOMAIN information. */
6846 tmp = array_type_nelts (decl_type);
6847 tmp = fold_convert (gfc_array_index_type, tmp);
6850 /* Remember that this is, in fact, the no. of elements - 1. */
6851 nelems = gfc_evaluate_now (tmp, &fnblock);
6852 index = gfc_create_var (gfc_array_index_type, "S");
6854 /* Build the body of the loop. */
6855 gfc_init_block (&loopbody);
6857 vref = gfc_build_array_ref (var, index, NULL);
6859 if (purpose == COPY_ALLOC_COMP)
6861 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
6863 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
6864 gfc_add_expr_to_block (&fnblock, tmp);
6866 tmp = build_fold_indirect_ref_loc (input_location,
6867 gfc_conv_array_data (dest));
6868 dref = gfc_build_array_ref (tmp, index, NULL);
6869 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
6871 else if (purpose == COPY_ONLY_ALLOC_COMP)
6873 tmp = build_fold_indirect_ref_loc (input_location,
6874 gfc_conv_array_data (dest));
6875 dref = gfc_build_array_ref (tmp, index, NULL);
6876 tmp = structure_alloc_comps (der_type, vref, dref, rank,
6880 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
6882 gfc_add_expr_to_block (&loopbody, tmp);
6884 /* Build the loop and return. */
6885 gfc_init_loopinfo (&loop);
6887 loop.from[0] = gfc_index_zero_node;
6888 loop.loopvar[0] = index;
6889 loop.to[0] = nelems;
6890 gfc_trans_scalarizing_loops (&loop, &loopbody);
6891 gfc_add_block_to_block (&fnblock, &loop.pre);
6893 tmp = gfc_finish_block (&fnblock);
6894 if (null_cond != NULL_TREE)
6895 tmp = build3_v (COND_EXPR, null_cond, tmp,
6896 build_empty_stmt (input_location));
6901 /* Otherwise, act on the components or recursively call self to
6902 act on a chain of components. */
6903 for (c = der_type->components; c; c = c->next)
6905 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
6906 || c->ts.type == BT_CLASS)
6907 && c->ts.u.derived->attr.alloc_comp;
6908 cdecl = c->backend_decl;
6909 ctype = TREE_TYPE (cdecl);
6913 case DEALLOCATE_ALLOC_COMP:
6914 if (cmp_has_alloc_comps && !c->attr.pointer)
6916 /* Do not deallocate the components of ultimate pointer
6918 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6919 decl, cdecl, NULL_TREE);
6920 rank = c->as ? c->as->rank : 0;
6921 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
6923 gfc_add_expr_to_block (&fnblock, tmp);
6926 if (c->attr.allocatable
6927 && (c->attr.dimension || c->attr.codimension))
6929 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6930 decl, cdecl, NULL_TREE);
6931 tmp = gfc_trans_dealloc_allocated (comp);
6932 gfc_add_expr_to_block (&fnblock, tmp);
6934 else if (c->attr.allocatable)
6936 /* Allocatable scalar components. */
6937 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6938 decl, cdecl, NULL_TREE);
6940 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6942 gfc_add_expr_to_block (&fnblock, tmp);
6944 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6945 void_type_node, comp,
6946 build_int_cst (TREE_TYPE (comp), 0));
6947 gfc_add_expr_to_block (&fnblock, tmp);
6949 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6951 /* Allocatable scalar CLASS components. */
6952 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6953 decl, cdecl, NULL_TREE);
6955 /* Add reference to '_data' component. */
6956 tmp = CLASS_DATA (c)->backend_decl;
6957 comp = fold_build3_loc (input_location, COMPONENT_REF,
6958 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
6960 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
6961 CLASS_DATA (c)->ts);
6962 gfc_add_expr_to_block (&fnblock, tmp);
6964 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6965 void_type_node, comp,
6966 build_int_cst (TREE_TYPE (comp), 0));
6967 gfc_add_expr_to_block (&fnblock, tmp);
6971 case NULLIFY_ALLOC_COMP:
6972 if (c->attr.pointer)
6974 else if (c->attr.allocatable
6975 && (c->attr.dimension|| c->attr.codimension))
6977 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6978 decl, cdecl, NULL_TREE);
6979 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
6981 else if (c->attr.allocatable)
6983 /* Allocatable scalar components. */
6984 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6985 decl, cdecl, NULL_TREE);
6986 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6987 void_type_node, comp,
6988 build_int_cst (TREE_TYPE (comp), 0));
6989 gfc_add_expr_to_block (&fnblock, tmp);
6991 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
6993 /* Allocatable scalar CLASS components. */
6994 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
6995 decl, cdecl, NULL_TREE);
6996 /* Add reference to '_data' component. */
6997 tmp = CLASS_DATA (c)->backend_decl;
6998 comp = fold_build3_loc (input_location, COMPONENT_REF,
6999 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7000 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7001 void_type_node, comp,
7002 build_int_cst (TREE_TYPE (comp), 0));
7003 gfc_add_expr_to_block (&fnblock, tmp);
7005 else if (cmp_has_alloc_comps)
7007 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7008 decl, cdecl, NULL_TREE);
7009 rank = c->as ? c->as->rank : 0;
7010 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7012 gfc_add_expr_to_block (&fnblock, tmp);
7016 case COPY_ALLOC_COMP:
7017 if (c->attr.pointer)
7020 /* We need source and destination components. */
7021 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7023 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7025 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7027 if (c->attr.allocatable && !cmp_has_alloc_comps)
7029 rank = c->as ? c->as->rank : 0;
7030 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7031 gfc_add_expr_to_block (&fnblock, tmp);
7034 if (cmp_has_alloc_comps)
7036 rank = c->as ? c->as->rank : 0;
7037 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7038 gfc_add_modify (&fnblock, dcmp, tmp);
7039 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7041 gfc_add_expr_to_block (&fnblock, tmp);
7051 return gfc_finish_block (&fnblock);
7054 /* Recursively traverse an object of derived type, generating code to
7055 nullify allocatable components. */
7058 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7060 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7061 NULLIFY_ALLOC_COMP);
7065 /* Recursively traverse an object of derived type, generating code to
7066 deallocate allocatable components. */
7069 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7071 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7072 DEALLOCATE_ALLOC_COMP);
7076 /* Recursively traverse an object of derived type, generating code to
7077 copy it and its allocatable components. */
7080 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7082 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7086 /* Recursively traverse an object of derived type, generating code to
7087 copy only its allocatable components. */
7090 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7092 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7096 /* Returns the value of LBOUND for an expression. This could be broken out
7097 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7098 called by gfc_alloc_allocatable_for_assignment. */
7100 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7105 tree cond, cond1, cond3, cond4;
7109 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7111 tmp = gfc_rank_cst[dim];
7112 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7113 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7114 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7115 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7117 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7118 stride, gfc_index_zero_node);
7119 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7120 boolean_type_node, cond3, cond1);
7121 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7122 stride, gfc_index_zero_node);
7124 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7125 tmp, build_int_cst (gfc_array_index_type,
7128 cond = boolean_false_node;
7130 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7131 boolean_type_node, cond3, cond4);
7132 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7133 boolean_type_node, cond, cond1);
7135 return fold_build3_loc (input_location, COND_EXPR,
7136 gfc_array_index_type, cond,
7137 lbound, gfc_index_one_node);
7139 else if (expr->expr_type == EXPR_VARIABLE)
7141 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7142 for (ref = expr->ref; ref; ref = ref->next)
7144 if (ref->type == REF_COMPONENT
7145 && ref->u.c.component->as
7147 && ref->next->u.ar.type == AR_FULL)
7148 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
7150 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
7152 else if (expr->expr_type == EXPR_FUNCTION)
7154 /* A conversion function, so use the argument. */
7155 expr = expr->value.function.actual->expr;
7156 if (expr->expr_type != EXPR_VARIABLE)
7157 return gfc_index_one_node;
7158 desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
7159 return get_std_lbound (expr, desc, dim, assumed_size);
7162 return gfc_index_one_node;
7166 /* Returns true if an expression represents an lhs that can be reallocated
7170 gfc_is_reallocatable_lhs (gfc_expr *expr)
7177 /* An allocatable variable. */
7178 if (expr->symtree->n.sym->attr.allocatable
7180 && expr->ref->type == REF_ARRAY
7181 && expr->ref->u.ar.type == AR_FULL)
7184 /* All that can be left are allocatable components. */
7185 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
7186 && expr->symtree->n.sym->ts.type != BT_CLASS)
7187 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7190 /* Find a component ref followed by an array reference. */
7191 for (ref = expr->ref; ref; ref = ref->next)
7193 && ref->type == REF_COMPONENT
7194 && ref->next->type == REF_ARRAY
7195 && !ref->next->next)
7201 /* Return true if valid reallocatable lhs. */
7202 if (ref->u.c.component->attr.allocatable
7203 && ref->next->u.ar.type == AR_FULL)
7210 /* Allocate the lhs of an assignment to an allocatable array, otherwise
7214 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
7218 stmtblock_t realloc_block;
7219 stmtblock_t alloc_block;
7242 gfc_array_spec * as;
7244 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
7245 Find the lhs expression in the loop chain and set expr1 and
7246 expr2 accordingly. */
7247 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
7250 /* Find the ss for the lhs. */
7252 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7253 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
7255 if (lss == gfc_ss_terminator)
7257 expr1 = lss->info->expr;
7260 /* Bail out if this is not a valid allocate on assignment. */
7261 if (!gfc_is_reallocatable_lhs (expr1)
7262 || (expr2 && !expr2->rank))
7265 /* Find the ss for the lhs. */
7267 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
7268 if (lss->info->expr == expr1)
7271 if (lss == gfc_ss_terminator)
7274 /* Find an ss for the rhs. For operator expressions, we see the
7275 ss's for the operands. Any one of these will do. */
7277 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
7278 if (rss->info->expr != expr1 && rss != loop->temp_ss)
7281 if (expr2 && rss == gfc_ss_terminator)
7284 gfc_start_block (&fblock);
7286 /* Since the lhs is allocatable, this must be a descriptor type.
7287 Get the data and array size. */
7288 desc = lss->data.info.descriptor;
7289 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
7290 array1 = gfc_conv_descriptor_data_get (desc);
7292 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
7293 deallocated if expr is an array of different shape or any of the
7294 corresponding length type parameter values of variable and expr
7295 differ." This assures F95 compatibility. */
7296 jump_label1 = gfc_build_label_decl (NULL_TREE);
7297 jump_label2 = gfc_build_label_decl (NULL_TREE);
7299 /* Allocate if data is NULL. */
7300 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7301 array1, build_int_cst (TREE_TYPE (array1), 0));
7302 tmp = build3_v (COND_EXPR, cond,
7303 build1_v (GOTO_EXPR, jump_label1),
7304 build_empty_stmt (input_location));
7305 gfc_add_expr_to_block (&fblock, tmp);
7307 /* Get arrayspec if expr is a full array. */
7308 if (expr2 && expr2->expr_type == EXPR_FUNCTION
7309 && expr2->value.function.isym
7310 && expr2->value.function.isym->conversion)
7312 /* For conversion functions, take the arg. */
7313 gfc_expr *arg = expr2->value.function.actual->expr;
7314 as = gfc_get_full_arrayspec_from_expr (arg);
7317 as = gfc_get_full_arrayspec_from_expr (expr2);
7321 /* If the lhs shape is not the same as the rhs jump to setting the
7322 bounds and doing the reallocation....... */
7323 for (n = 0; n < expr1->rank; n++)
7325 /* Check the shape. */
7326 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7327 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
7328 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7329 gfc_array_index_type,
7330 loop->to[n], loop->from[n]);
7331 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7332 gfc_array_index_type,
7334 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7335 gfc_array_index_type,
7337 cond = fold_build2_loc (input_location, NE_EXPR,
7339 tmp, gfc_index_zero_node);
7340 tmp = build3_v (COND_EXPR, cond,
7341 build1_v (GOTO_EXPR, jump_label1),
7342 build_empty_stmt (input_location));
7343 gfc_add_expr_to_block (&fblock, tmp);
7346 /* ....else jump past the (re)alloc code. */
7347 tmp = build1_v (GOTO_EXPR, jump_label2);
7348 gfc_add_expr_to_block (&fblock, tmp);
7350 /* Add the label to start automatic (re)allocation. */
7351 tmp = build1_v (LABEL_EXPR, jump_label1);
7352 gfc_add_expr_to_block (&fblock, tmp);
7354 size1 = gfc_conv_descriptor_size (desc, expr1->rank);
7356 /* Get the rhs size. Fix both sizes. */
7358 desc2 = rss->data.info.descriptor;
7361 size2 = gfc_index_one_node;
7362 for (n = 0; n < expr2->rank; n++)
7364 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7365 gfc_array_index_type,
7366 loop->to[n], loop->from[n]);
7367 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7368 gfc_array_index_type,
7369 tmp, gfc_index_one_node);
7370 size2 = fold_build2_loc (input_location, MULT_EXPR,
7371 gfc_array_index_type,
7375 size1 = gfc_evaluate_now (size1, &fblock);
7376 size2 = gfc_evaluate_now (size2, &fblock);
7378 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7380 neq_size = gfc_evaluate_now (cond, &fblock);
7383 /* Now modify the lhs descriptor and the associated scalarizer
7384 variables. F2003 7.4.1.3: "If variable is or becomes an
7385 unallocated allocatable variable, then it is allocated with each
7386 deferred type parameter equal to the corresponding type parameters
7387 of expr , with the shape of expr , and with each lower bound equal
7388 to the corresponding element of LBOUND(expr)."
7389 Reuse size1 to keep a dimension-by-dimension track of the
7390 stride of the new array. */
7391 size1 = gfc_index_one_node;
7392 offset = gfc_index_zero_node;
7394 for (n = 0; n < expr2->rank; n++)
7396 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7397 gfc_array_index_type,
7398 loop->to[n], loop->from[n]);
7399 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7400 gfc_array_index_type,
7401 tmp, gfc_index_one_node);
7403 lbound = gfc_index_one_node;
7408 lbd = get_std_lbound (expr2, desc2, n,
7409 as->type == AS_ASSUMED_SIZE);
7410 ubound = fold_build2_loc (input_location,
7412 gfc_array_index_type,
7414 ubound = fold_build2_loc (input_location,
7416 gfc_array_index_type,
7421 gfc_conv_descriptor_lbound_set (&fblock, desc,
7424 gfc_conv_descriptor_ubound_set (&fblock, desc,
7427 gfc_conv_descriptor_stride_set (&fblock, desc,
7430 lbound = gfc_conv_descriptor_lbound_get (desc,
7432 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
7433 gfc_array_index_type,
7435 offset = fold_build2_loc (input_location, MINUS_EXPR,
7436 gfc_array_index_type,
7438 size1 = fold_build2_loc (input_location, MULT_EXPR,
7439 gfc_array_index_type,
7443 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
7444 the array offset is saved and the info.offset is used for a
7445 running offset. Use the saved_offset instead. */
7446 tmp = gfc_conv_descriptor_offset (desc);
7447 gfc_add_modify (&fblock, tmp, offset);
7448 if (lss->data.info.saved_offset
7449 && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
7450 gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
7452 /* Now set the deltas for the lhs. */
7453 for (n = 0; n < expr1->rank; n++)
7455 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
7457 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7458 gfc_array_index_type, tmp,
7460 if (lss->data.info.delta[dim]
7461 && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
7462 gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
7465 /* Get the new lhs size in bytes. */
7466 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
7468 tmp = expr2->ts.u.cl->backend_decl;
7469 gcc_assert (expr1->ts.u.cl->backend_decl);
7470 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
7471 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
7473 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
7475 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
7476 tmp = fold_build2_loc (input_location, MULT_EXPR,
7477 gfc_array_index_type, tmp,
7478 expr1->ts.u.cl->backend_decl);
7481 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
7482 tmp = fold_convert (gfc_array_index_type, tmp);
7483 size2 = fold_build2_loc (input_location, MULT_EXPR,
7484 gfc_array_index_type,
7486 size2 = fold_convert (size_type_node, size2);
7487 size2 = gfc_evaluate_now (size2, &fblock);
7489 /* Realloc expression. Note that the scalarizer uses desc.data
7490 in the array reference - (*desc.data)[<element>]. */
7491 gfc_init_block (&realloc_block);
7492 tmp = build_call_expr_loc (input_location,
7493 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
7494 fold_convert (pvoid_type_node, array1),
7496 gfc_conv_descriptor_data_set (&realloc_block,
7498 realloc_expr = gfc_finish_block (&realloc_block);
7500 /* Only reallocate if sizes are different. */
7501 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
7502 build_empty_stmt (input_location));
7506 /* Malloc expression. */
7507 gfc_init_block (&alloc_block);
7508 tmp = build_call_expr_loc (input_location,
7509 builtin_decl_explicit (BUILT_IN_MALLOC),
7511 gfc_conv_descriptor_data_set (&alloc_block,
7513 tmp = gfc_conv_descriptor_dtype (desc);
7514 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
7515 alloc_expr = gfc_finish_block (&alloc_block);
7517 /* Malloc if not allocated; realloc otherwise. */
7518 tmp = build_int_cst (TREE_TYPE (array1), 0);
7519 cond = fold_build2_loc (input_location, EQ_EXPR,
7522 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
7523 gfc_add_expr_to_block (&fblock, tmp);
7525 /* Make sure that the scalarizer data pointer is updated. */
7526 if (lss->data.info.data
7527 && TREE_CODE (lss->data.info.data) == VAR_DECL)
7529 tmp = gfc_conv_descriptor_data_get (desc);
7530 gfc_add_modify (&fblock, lss->data.info.data, tmp);
7533 /* Add the exit label. */
7534 tmp = build1_v (LABEL_EXPR, jump_label2);
7535 gfc_add_expr_to_block (&fblock, tmp);
7537 return gfc_finish_block (&fblock);
7541 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
7542 Do likewise, recursively if necessary, with the allocatable components of
7546 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
7552 stmtblock_t cleanup;
7555 bool sym_has_alloc_comp;
7557 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
7558 || sym->ts.type == BT_CLASS)
7559 && sym->ts.u.derived->attr.alloc_comp;
7561 /* Make sure the frontend gets these right. */
7562 if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
7563 fatal_error ("Possible front-end bug: Deferred array size without pointer, "
7564 "allocatable attribute or derived type without allocatable "
7567 gfc_save_backend_locus (&loc);
7568 gfc_set_backend_locus (&sym->declared_at);
7569 gfc_init_block (&init);
7571 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
7572 || TREE_CODE (sym->backend_decl) == PARM_DECL);
7574 if (sym->ts.type == BT_CHARACTER
7575 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7577 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7578 gfc_trans_vla_type_sizes (sym, &init);
7581 /* Dummy, use associated and result variables don't need anything special. */
7582 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
7584 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7585 gfc_restore_backend_locus (&loc);
7589 descriptor = sym->backend_decl;
7591 /* Although static, derived types with default initializers and
7592 allocatable components must not be nulled wholesale; instead they
7593 are treated component by component. */
7594 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
7596 /* SAVEd variables are not freed on exit. */
7597 gfc_trans_static_array_pointer (sym);
7599 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
7600 gfc_restore_backend_locus (&loc);
7604 /* Get the descriptor type. */
7605 type = TREE_TYPE (sym->backend_decl);
7607 if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
7610 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
7612 if (sym->value == NULL
7613 || !gfc_has_default_initializer (sym->ts.u.derived))
7615 rank = sym->as ? sym->as->rank : 0;
7616 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
7618 gfc_add_expr_to_block (&init, tmp);
7621 gfc_init_default_dt (sym, &init, false);
7624 else if (!GFC_DESCRIPTOR_TYPE_P (type))
7626 /* If the backend_decl is not a descriptor, we must have a pointer
7628 descriptor = build_fold_indirect_ref_loc (input_location,
7630 type = TREE_TYPE (descriptor);
7633 /* NULLIFY the data pointer. */
7634 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
7635 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
7637 gfc_restore_backend_locus (&loc);
7638 gfc_init_block (&cleanup);
7640 /* Allocatable arrays need to be freed when they go out of scope.
7641 The allocatable components of pointers must not be touched. */
7642 if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
7643 && !sym->attr.pointer && !sym->attr.save)
7646 rank = sym->as ? sym->as->rank : 0;
7647 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
7648 gfc_add_expr_to_block (&cleanup, tmp);
7651 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
7652 && !sym->attr.save && !sym->attr.result)
7654 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
7655 gfc_add_expr_to_block (&cleanup, tmp);
7658 gfc_add_init_cleanup (block, gfc_finish_block (&init),
7659 gfc_finish_block (&cleanup));
7662 /************ Expression Walking Functions ******************/
7664 /* Walk a variable reference.
7666 Possible extension - multiple component subscripts.
7667 x(:,:) = foo%a(:)%b(:)
7669 forall (i=..., j=...)
7670 x(i,j) = foo%a(j)%b(i)
7672 This adds a fair amount of complexity because you need to deal with more
7673 than one ref. Maybe handle in a similar manner to vector subscripts.
7674 Maybe not worth the effort. */
7678 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
7682 for (ref = expr->ref; ref; ref = ref->next)
7683 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7686 return gfc_walk_array_ref (ss, expr, ref);
7691 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
7697 for (; ref; ref = ref->next)
7699 if (ref->type == REF_SUBSTRING)
7701 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
7702 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
7705 /* We're only interested in array sections from now on. */
7706 if (ref->type != REF_ARRAY)
7714 for (n = ar->dimen - 1; n >= 0; n--)
7715 ss = gfc_get_scalar_ss (ss, ar->start[n]);
7719 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
7720 newss->data.info.ref = ref;
7722 /* Make sure array is the same as array(:,:), this way
7723 we don't need to special case all the time. */
7724 ar->dimen = ar->as->rank;
7725 for (n = 0; n < ar->dimen; n++)
7727 ar->dimen_type[n] = DIMEN_RANGE;
7729 gcc_assert (ar->start[n] == NULL);
7730 gcc_assert (ar->end[n] == NULL);
7731 gcc_assert (ar->stride[n] == NULL);
7737 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
7738 newss->data.info.ref = ref;
7740 /* We add SS chains for all the subscripts in the section. */
7741 for (n = 0; n < ar->dimen; n++)
7745 switch (ar->dimen_type[n])
7748 /* Add SS for elemental (scalar) subscripts. */
7749 gcc_assert (ar->start[n]);
7750 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
7751 indexss->loop_chain = gfc_ss_terminator;
7752 newss->data.info.subscript[n] = indexss;
7756 /* We don't add anything for sections, just remember this
7757 dimension for later. */
7758 newss->dim[newss->dimen] = n;
7763 /* Create a GFC_SS_VECTOR index in which we can store
7764 the vector's descriptor. */
7765 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
7767 indexss->loop_chain = gfc_ss_terminator;
7768 newss->data.info.subscript[n] = indexss;
7769 newss->dim[newss->dimen] = n;
7774 /* We should know what sort of section it is by now. */
7778 /* We should have at least one non-elemental dimension,
7779 unless we are creating a descriptor for a (scalar) coarray. */
7780 gcc_assert (newss->dimen > 0
7781 || newss->data.info.ref->u.ar.as->corank > 0);
7786 /* We should know what sort of section it is by now. */
7795 /* Walk an expression operator. If only one operand of a binary expression is
7796 scalar, we must also add the scalar term to the SS chain. */
7799 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
7804 head = gfc_walk_subexpr (ss, expr->value.op.op1);
7805 if (expr->value.op.op2 == NULL)
7808 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
7810 /* All operands are scalar. Pass back and let the caller deal with it. */
7814 /* All operands require scalarization. */
7815 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
7818 /* One of the operands needs scalarization, the other is scalar.
7819 Create a gfc_ss for the scalar expression. */
7822 /* First operand is scalar. We build the chain in reverse order, so
7823 add the scalar SS after the second operand. */
7825 while (head && head->next != ss)
7827 /* Check we haven't somehow broken the chain. */
7829 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
7831 else /* head2 == head */
7833 gcc_assert (head2 == head);
7834 /* Second operand is scalar. */
7835 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
7842 /* Reverse a SS chain. */
7845 gfc_reverse_ss (gfc_ss * ss)
7850 gcc_assert (ss != NULL);
7852 head = gfc_ss_terminator;
7853 while (ss != gfc_ss_terminator)
7856 /* Check we didn't somehow break the chain. */
7857 gcc_assert (next != NULL);
7867 /* Walk the arguments of an elemental function. */
7870 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
7878 head = gfc_ss_terminator;
7881 for (; arg; arg = arg->next)
7886 newss = gfc_walk_subexpr (head, arg->expr);
7889 /* Scalar argument. */
7890 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
7891 newss = gfc_get_scalar_ss (head, arg->expr);
7892 newss->info->type = type;
7901 while (tail->next != gfc_ss_terminator)
7908 /* If all the arguments are scalar we don't need the argument SS. */
7909 gfc_free_ss_chain (head);
7914 /* Add it onto the existing chain. */
7920 /* Walk a function call. Scalar functions are passed back, and taken out of
7921 scalarization loops. For elemental functions we walk their arguments.
7922 The result of functions returning arrays is stored in a temporary outside
7923 the loop, so that the function is only called once. Hence we do not need
7924 to walk their arguments. */
7927 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
7929 gfc_intrinsic_sym *isym;
7931 gfc_component *comp = NULL;
7933 isym = expr->value.function.isym;
7935 /* Handle intrinsic functions separately. */
7937 return gfc_walk_intrinsic_function (ss, expr, isym);
7939 sym = expr->value.function.esym;
7941 sym = expr->symtree->n.sym;
7943 /* A function that returns arrays. */
7944 gfc_is_proc_ptr_comp (expr, &comp);
7945 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
7946 || (comp && comp->attr.dimension))
7947 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
7949 /* Walk the parameters of an elemental function. For now we always pass
7951 if (sym->attr.elemental)
7952 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7955 /* Scalar functions are OK as these are evaluated outside the scalarization
7956 loop. Pass back and let the caller deal with it. */
7961 /* An array temporary is constructed for array constructors. */
7964 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
7966 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
7970 /* Walk an expression. Add walked expressions to the head of the SS chain.
7971 A wholly scalar expression will not be added. */
7974 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
7978 switch (expr->expr_type)
7981 head = gfc_walk_variable_expr (ss, expr);
7985 head = gfc_walk_op_expr (ss, expr);
7989 head = gfc_walk_function_expr (ss, expr);
7994 case EXPR_STRUCTURE:
7995 /* Pass back and let the caller deal with it. */
7999 head = gfc_walk_array_constructor (ss, expr);
8002 case EXPR_SUBSTRING:
8003 /* Pass back and let the caller deal with it. */
8007 internal_error ("bad expression type during walk (%d)",
8014 /* Entry point for expression walking.
8015 A return value equal to the passed chain means this is
8016 a scalar expression. It is up to the caller to take whatever action is
8017 necessary to translate these. */
8020 gfc_walk_expr (gfc_expr * expr)
8024 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
8025 return gfc_reverse_ss (res);