1 /* Array translation routines
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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 subecripts 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"
84 #include "tree-gimple.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
100 /* The contents of this structure aren't actually used, just the address. */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
106 gfc_array_dataptr_type (tree desc)
108 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
112 /* Build expressions to access the members of an array descriptor.
113 It's surprisingly easy to mess up here, so never access
114 an array descriptor by "brute force", always use these
115 functions. This also avoids problems if we change the format
116 of an array descriptor.
118 To understand these magic numbers, look at the comments
119 before gfc_build_array_type() in trans-types.c.
121 The code within these defines should be the only code which knows the format
122 of an array descriptor.
124 Any code just needing to read obtain the bounds of an array should use
125 gfc_conv_array_* rather than the following functions as these will return
126 know constant values, and work with arrays which do not have descriptors.
128 Don't forget to #undef these! */
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
139 /* This provides READ-ONLY access to the data field. The field itself
140 doesn't have the proper type. */
143 gfc_conv_descriptor_data_get (tree desc)
147 type = TREE_TYPE (desc);
148 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
150 field = TYPE_FIELDS (type);
151 gcc_assert (DATA_FIELD == 0);
153 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
159 /* This provides WRITE access to the data field. */
162 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
166 type = TREE_TYPE (desc);
167 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
169 field = TYPE_FIELDS (type);
170 gcc_assert (DATA_FIELD == 0);
172 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
173 gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
177 /* This provides address access to the data field. This should only be
178 used by array allocation, passing this on to the runtime. */
181 gfc_conv_descriptor_data_addr (tree desc)
185 type = TREE_TYPE (desc);
186 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
188 field = TYPE_FIELDS (type);
189 gcc_assert (DATA_FIELD == 0);
191 t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
192 return build_fold_addr_expr (t);
196 gfc_conv_descriptor_offset (tree desc)
201 type = TREE_TYPE (desc);
202 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
204 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
205 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
207 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
211 gfc_conv_descriptor_dtype (tree desc)
216 type = TREE_TYPE (desc);
217 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
219 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
220 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
222 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
226 gfc_conv_descriptor_dimension (tree desc, tree dim)
232 type = TREE_TYPE (desc);
233 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
235 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
236 gcc_assert (field != NULL_TREE
237 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
238 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
240 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
241 tmp = gfc_build_array_ref (tmp, dim);
246 gfc_conv_descriptor_stride (tree desc, tree dim)
251 tmp = gfc_conv_descriptor_dimension (desc, dim);
252 field = TYPE_FIELDS (TREE_TYPE (tmp));
253 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
254 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
256 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
261 gfc_conv_descriptor_lbound (tree desc, tree dim)
266 tmp = gfc_conv_descriptor_dimension (desc, dim);
267 field = TYPE_FIELDS (TREE_TYPE (tmp));
268 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
269 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
271 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
276 gfc_conv_descriptor_ubound (tree desc, tree dim)
281 tmp = gfc_conv_descriptor_dimension (desc, dim);
282 field = TYPE_FIELDS (TREE_TYPE (tmp));
283 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
284 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
286 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
291 /* Build a null array descriptor constructor. */
294 gfc_build_null_descriptor (tree type)
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
300 gcc_assert (DATA_FIELD == 0);
301 field = TYPE_FIELDS (type);
303 /* Set a NULL data pointer. */
304 tmp = build_constructor_single (type, field, null_pointer_node);
305 TREE_CONSTANT (tmp) = 1;
306 TREE_INVARIANT (tmp) = 1;
307 /* All other fields are ignored. */
313 /* Cleanup those #defines. */
318 #undef DIMENSION_FIELD
319 #undef STRIDE_SUBFIELD
320 #undef LBOUND_SUBFIELD
321 #undef UBOUND_SUBFIELD
324 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
325 flags & 1 = Main loop body.
326 flags & 2 = temp copy loop. */
329 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
331 for (; ss != gfc_ss_terminator; ss = ss->next)
332 ss->useflags = flags;
335 static void gfc_free_ss (gfc_ss *);
338 /* Free a gfc_ss chain. */
341 gfc_free_ss_chain (gfc_ss * ss)
345 while (ss != gfc_ss_terminator)
347 gcc_assert (ss != NULL);
358 gfc_free_ss (gfc_ss * ss)
365 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
367 if (ss->data.info.subscript[n])
368 gfc_free_ss_chain (ss->data.info.subscript[n]);
380 /* Free all the SS associated with a loop. */
383 gfc_cleanup_loop (gfc_loopinfo * loop)
389 while (ss != gfc_ss_terminator)
391 gcc_assert (ss != NULL);
392 next = ss->loop_chain;
399 /* Associate a SS chain with a loop. */
402 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
406 if (head == gfc_ss_terminator)
410 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
412 if (ss->next == gfc_ss_terminator)
413 ss->loop_chain = loop->ss;
415 ss->loop_chain = ss->next;
417 gcc_assert (ss == gfc_ss_terminator);
422 /* Generate an initializer for a static pointer or allocatable array. */
425 gfc_trans_static_array_pointer (gfc_symbol * sym)
429 gcc_assert (TREE_STATIC (sym->backend_decl));
430 /* Just zero the data member. */
431 type = TREE_TYPE (sym->backend_decl);
432 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
436 /* If the bounds of SE's loop have not yet been set, see if they can be
437 determined from array spec AS, which is the array spec of a called
438 function. MAPPING maps the callee's dummy arguments to the values
439 that the caller is passing. Add any initialization and finalization
443 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
444 gfc_se * se, gfc_array_spec * as)
452 if (as && as->type == AS_EXPLICIT)
453 for (dim = 0; dim < se->loop->dimen; dim++)
455 n = se->loop->order[dim];
456 if (se->loop->to[n] == NULL_TREE)
458 /* Evaluate the lower bound. */
459 gfc_init_se (&tmpse, NULL);
460 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
461 gfc_add_block_to_block (&se->pre, &tmpse.pre);
462 gfc_add_block_to_block (&se->post, &tmpse.post);
465 /* ...and the upper bound. */
466 gfc_init_se (&tmpse, NULL);
467 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
468 gfc_add_block_to_block (&se->pre, &tmpse.pre);
469 gfc_add_block_to_block (&se->post, &tmpse.post);
472 /* Set the upper bound of the loop to UPPER - LOWER. */
473 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
474 tmp = gfc_evaluate_now (tmp, &se->pre);
475 se->loop->to[n] = tmp;
481 /* Generate code to allocate an array temporary, or create a variable to
482 hold the data. If size is NULL, zero the descriptor so that the
483 callee will allocate the array. If DEALLOC is true, also generate code to
484 free the array afterwards.
486 Initialization code is added to PRE and finalization code to POST.
487 DYNAMIC is true if the caller may want to extend the array later
488 using realloc. This prevents us from putting the array on the stack. */
491 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
492 gfc_ss_info * info, tree size, tree nelem,
493 bool dynamic, bool dealloc)
500 desc = info->descriptor;
501 info->offset = gfc_index_zero_node;
502 if (size == NULL_TREE || integer_zerop (size))
504 /* A callee allocated array. */
505 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
510 /* Allocate the temporary. */
511 onstack = !dynamic && gfc_can_put_var_on_stack (size);
515 /* Make a temporary variable to hold the data. */
516 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
518 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
520 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
522 tmp = gfc_create_var (tmp, "A");
523 tmp = build_fold_addr_expr (tmp);
524 gfc_conv_descriptor_data_set (pre, desc, tmp);
528 /* Allocate memory to hold the data. */
529 args = gfc_chainon_list (NULL_TREE, size);
531 if (gfc_index_integer_kind == 4)
532 tmp = gfor_fndecl_internal_malloc;
533 else if (gfc_index_integer_kind == 8)
534 tmp = gfor_fndecl_internal_malloc64;
537 tmp = build_function_call_expr (tmp, args);
538 tmp = gfc_evaluate_now (tmp, pre);
539 gfc_conv_descriptor_data_set (pre, desc, tmp);
542 info->data = gfc_conv_descriptor_data_get (desc);
544 /* The offset is zero because we create temporaries with a zero
546 tmp = gfc_conv_descriptor_offset (desc);
547 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
549 if (dealloc && !onstack)
551 /* Free the temporary. */
552 tmp = gfc_conv_descriptor_data_get (desc);
553 tmp = fold_convert (pvoid_type_node, tmp);
554 tmp = gfc_chainon_list (NULL_TREE, tmp);
555 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
556 gfc_add_expr_to_block (post, tmp);
561 /* Generate code to create and initialize the descriptor for a temporary
562 array. This is used for both temporaries needed by the scalarizer, and
563 functions returning arrays. Adjusts the loop variables to be
564 zero-based, and calculates the loop bounds for callee allocated arrays.
565 Allocate the array unless it's callee allocated (we have a callee
566 allocated array if 'callee_alloc' is true, or if loop->to[n] is
567 NULL_TREE for any n). Also fills in the descriptor, data and offset
568 fields of info if known. Returns the size of the array, or NULL for a
569 callee allocated array.
571 PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
575 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
576 gfc_loopinfo * loop, gfc_ss_info * info,
577 tree eltype, bool dynamic, bool dealloc,
588 gcc_assert (info->dimen > 0);
589 /* Set the lower bound to zero. */
590 for (dim = 0; dim < info->dimen; dim++)
592 n = loop->order[dim];
593 if (n < loop->temp_dim)
594 gcc_assert (integer_zerop (loop->from[n]));
597 /* Callee allocated arrays may not have a known bound yet. */
599 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
600 loop->to[n], loop->from[n]);
601 loop->from[n] = gfc_index_zero_node;
604 info->delta[dim] = gfc_index_zero_node;
605 info->start[dim] = gfc_index_zero_node;
606 info->stride[dim] = gfc_index_one_node;
607 info->dim[dim] = dim;
610 /* Initialize the descriptor. */
612 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
613 desc = gfc_create_var (type, "atmp");
614 GFC_DECL_PACKED_ARRAY (desc) = 1;
616 info->descriptor = desc;
617 size = gfc_index_one_node;
619 /* Fill in the array dtype. */
620 tmp = gfc_conv_descriptor_dtype (desc);
621 gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
624 Fill in the bounds and stride. This is a packed array, so:
627 for (n = 0; n < rank; n++)
630 delta = ubound[n] + 1 - lbound[n];
633 size = size * sizeof(element);
636 for (n = 0; n < info->dimen; n++)
638 if (loop->to[n] == NULL_TREE)
640 /* For a callee allocated array express the loop bounds in terms
641 of the descriptor fields. */
642 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
643 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
644 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
650 /* Store the stride and bound components in the descriptor. */
651 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
652 gfc_add_modify_expr (pre, tmp, size);
654 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
655 gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
657 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
658 gfc_add_modify_expr (pre, tmp, loop->to[n]);
660 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
661 loop->to[n], gfc_index_one_node);
663 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
664 size = gfc_evaluate_now (size, pre);
667 /* Get the size of the array. */
669 if (size && !callee_alloc)
670 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
671 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
675 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
678 if (info->dimen > loop->temp_dim)
679 loop->temp_dim = info->dimen;
685 /* Generate code to transpose array EXPR by creating a new descriptor
686 in which the dimension specifications have been reversed. */
689 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
691 tree dest, src, dest_index, src_index;
693 gfc_ss_info *dest_info, *src_info;
694 gfc_ss *dest_ss, *src_ss;
700 src_ss = gfc_walk_expr (expr);
703 src_info = &src_ss->data.info;
704 dest_info = &dest_ss->data.info;
706 /* Get a descriptor for EXPR. */
707 gfc_init_se (&src_se, NULL);
708 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
709 gfc_add_block_to_block (&se->pre, &src_se.pre);
710 gfc_add_block_to_block (&se->post, &src_se.post);
713 /* Allocate a new descriptor for the return value. */
714 dest = gfc_create_var (TREE_TYPE (src), "atmp");
715 dest_info->descriptor = dest;
718 /* Copy across the dtype field. */
719 gfc_add_modify_expr (&se->pre,
720 gfc_conv_descriptor_dtype (dest),
721 gfc_conv_descriptor_dtype (src));
723 /* Copy the dimension information, renumbering dimension 1 to 0 and
725 gcc_assert (dest_info->dimen == 2);
726 gcc_assert (src_info->dimen == 2);
727 for (n = 0; n < 2; n++)
729 dest_info->delta[n] = gfc_index_zero_node;
730 dest_info->start[n] = gfc_index_zero_node;
731 dest_info->stride[n] = gfc_index_one_node;
732 dest_info->dim[n] = n;
734 dest_index = gfc_rank_cst[n];
735 src_index = gfc_rank_cst[1 - n];
737 gfc_add_modify_expr (&se->pre,
738 gfc_conv_descriptor_stride (dest, dest_index),
739 gfc_conv_descriptor_stride (src, src_index));
741 gfc_add_modify_expr (&se->pre,
742 gfc_conv_descriptor_lbound (dest, dest_index),
743 gfc_conv_descriptor_lbound (src, src_index));
745 gfc_add_modify_expr (&se->pre,
746 gfc_conv_descriptor_ubound (dest, dest_index),
747 gfc_conv_descriptor_ubound (src, src_index));
751 gcc_assert (integer_zerop (loop->from[n]));
752 loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
753 gfc_conv_descriptor_ubound (dest, dest_index),
754 gfc_conv_descriptor_lbound (dest, dest_index));
758 /* Copy the data pointer. */
759 dest_info->data = gfc_conv_descriptor_data_get (src);
760 gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
762 /* Copy the offset. This is not changed by transposition: the top-left
763 element is still at the same offset as before. */
764 dest_info->offset = gfc_conv_descriptor_offset (src);
765 gfc_add_modify_expr (&se->pre,
766 gfc_conv_descriptor_offset (dest),
769 if (dest_info->dimen > loop->temp_dim)
770 loop->temp_dim = dest_info->dimen;
774 /* Return the number of iterations in a loop that starts at START,
775 ends at END, and has step STEP. */
778 gfc_get_iteration_count (tree start, tree end, tree step)
783 type = TREE_TYPE (step);
784 tmp = fold_build2 (MINUS_EXPR, type, end, start);
785 tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
786 tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
787 tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
788 return fold_convert (gfc_array_index_type, tmp);
792 /* Extend the data in array DESC by EXTRA elements. */
795 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
802 if (integer_zerop (extra))
805 ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
807 /* Add EXTRA to the upper bound. */
808 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
809 gfc_add_modify_expr (pblock, ubound, tmp);
811 /* Get the value of the current data pointer. */
812 tmp = gfc_conv_descriptor_data_get (desc);
813 args = gfc_chainon_list (NULL_TREE, tmp);
815 /* Calculate the new array size. */
816 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
817 tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
818 tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
819 args = gfc_chainon_list (args, tmp);
821 /* Pick the appropriate realloc function. */
822 if (gfc_index_integer_kind == 4)
823 tmp = gfor_fndecl_internal_realloc;
824 else if (gfc_index_integer_kind == 8)
825 tmp = gfor_fndecl_internal_realloc64;
829 /* Set the new data pointer. */
830 tmp = build_function_call_expr (tmp, args);
831 gfc_conv_descriptor_data_set (pblock, desc, tmp);
835 /* Return true if the bounds of iterator I can only be determined
839 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
841 return (i->start->expr_type != EXPR_CONSTANT
842 || i->end->expr_type != EXPR_CONSTANT
843 || i->step->expr_type != EXPR_CONSTANT);
847 /* Split the size of constructor element EXPR into the sum of two terms,
848 one of which can be determined at compile time and one of which must
849 be calculated at run time. Set *SIZE to the former and return true
850 if the latter might be nonzero. */
853 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
855 if (expr->expr_type == EXPR_ARRAY)
856 return gfc_get_array_constructor_size (size, expr->value.constructor);
857 else if (expr->rank > 0)
859 /* Calculate everything at run time. */
860 mpz_set_ui (*size, 0);
865 /* A single element. */
866 mpz_set_ui (*size, 1);
872 /* Like gfc_get_array_constructor_element_size, but applied to the whole
873 of array constructor C. */
876 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
883 mpz_set_ui (*size, 0);
888 for (; c; c = c->next)
891 if (i && gfc_iterator_has_dynamic_bounds (i))
895 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
898 /* Multiply the static part of the element size by the
899 number of iterations. */
900 mpz_sub (val, i->end->value.integer, i->start->value.integer);
901 mpz_fdiv_q (val, val, i->step->value.integer);
902 mpz_add_ui (val, val, 1);
903 if (mpz_sgn (val) > 0)
904 mpz_mul (len, len, val);
908 mpz_add (*size, *size, len);
917 /* Make sure offset is a variable. */
920 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
923 /* We should have already created the offset variable. We cannot
924 create it here because we may be in an inner scope. */
925 gcc_assert (*offsetvar != NULL_TREE);
926 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
927 *poffset = *offsetvar;
928 TREE_USED (*offsetvar) = 1;
932 /* Assign an element of an array constructor. */
935 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
936 tree offset, gfc_se * se, gfc_expr * expr)
941 gfc_conv_expr (se, expr);
943 /* Store the value. */
944 tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
945 tmp = gfc_build_array_ref (tmp, offset);
946 if (expr->ts.type == BT_CHARACTER)
948 gfc_conv_string_parameter (se);
949 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
951 /* The temporary is an array of pointers. */
952 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
953 gfc_add_modify_expr (&se->pre, tmp, se->expr);
957 /* The temporary is an array of string values. */
958 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
959 /* We know the temporary and the value will be the same length,
960 so can use memcpy. */
961 args = gfc_chainon_list (NULL_TREE, tmp);
962 args = gfc_chainon_list (args, se->expr);
963 args = gfc_chainon_list (args, se->string_length);
964 tmp = built_in_decls[BUILT_IN_MEMCPY];
965 tmp = build_function_call_expr (tmp, args);
966 gfc_add_expr_to_block (&se->pre, tmp);
971 /* TODO: Should the frontend already have done this conversion? */
972 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
973 gfc_add_modify_expr (&se->pre, tmp, se->expr);
976 gfc_add_block_to_block (pblock, &se->pre);
977 gfc_add_block_to_block (pblock, &se->post);
981 /* Add the contents of an array to the constructor. DYNAMIC is as for
982 gfc_trans_array_constructor_value. */
985 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
986 tree type ATTRIBUTE_UNUSED,
987 tree desc, gfc_expr * expr,
988 tree * poffset, tree * offsetvar,
999 /* We need this to be a variable so we can increment it. */
1000 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1002 gfc_init_se (&se, NULL);
1004 /* Walk the array expression. */
1005 ss = gfc_walk_expr (expr);
1006 gcc_assert (ss != gfc_ss_terminator);
1008 /* Initialize the scalarizer. */
1009 gfc_init_loopinfo (&loop);
1010 gfc_add_ss_to_loop (&loop, ss);
1012 /* Initialize the loop. */
1013 gfc_conv_ss_startstride (&loop);
1014 gfc_conv_loop_setup (&loop);
1016 /* Make sure the constructed array has room for the new data. */
1019 /* Set SIZE to the total number of elements in the subarray. */
1020 size = gfc_index_one_node;
1021 for (n = 0; n < loop.dimen; n++)
1023 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1024 gfc_index_one_node);
1025 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1028 /* Grow the constructed array by SIZE elements. */
1029 gfc_grow_array (&loop.pre, desc, size);
1032 /* Make the loop body. */
1033 gfc_mark_ss_chain_used (ss, 1);
1034 gfc_start_scalarized_body (&loop, &body);
1035 gfc_copy_loopinfo_to_se (&se, &loop);
1038 if (expr->ts.type == BT_CHARACTER)
1039 gfc_todo_error ("character arrays in constructors");
1041 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1042 gcc_assert (se.ss == gfc_ss_terminator);
1044 /* Increment the offset. */
1045 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1046 gfc_add_modify_expr (&body, *poffset, tmp);
1048 /* Finish the loop. */
1049 gfc_trans_scalarizing_loops (&loop, &body);
1050 gfc_add_block_to_block (&loop.pre, &loop.post);
1051 tmp = gfc_finish_block (&loop.pre);
1052 gfc_add_expr_to_block (pblock, tmp);
1054 gfc_cleanup_loop (&loop);
1058 /* Assign the values to the elements of an array constructor. DYNAMIC
1059 is true if descriptor DESC only contains enough data for the static
1060 size calculated by gfc_get_array_constructor_size. When true, memory
1061 for the dynamic parts must be allocated using realloc. */
1064 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1065 tree desc, gfc_constructor * c,
1066 tree * poffset, tree * offsetvar,
1075 for (; c; c = c->next)
1077 /* If this is an iterator or an array, the offset must be a variable. */
1078 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1079 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1081 gfc_start_block (&body);
1083 if (c->expr->expr_type == EXPR_ARRAY)
1085 /* Array constructors can be nested. */
1086 gfc_trans_array_constructor_value (&body, type, desc,
1087 c->expr->value.constructor,
1088 poffset, offsetvar, dynamic);
1090 else if (c->expr->rank > 0)
1092 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1093 poffset, offsetvar, dynamic);
1097 /* This code really upsets the gimplifier so don't bother for now. */
1104 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1111 /* Scalar values. */
1112 gfc_init_se (&se, NULL);
1113 gfc_trans_array_ctor_element (&body, desc, *poffset,
1116 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1117 *poffset, gfc_index_one_node);
1121 /* Collect multiple scalar constants into a constructor. */
1129 /* Count the number of consecutive scalar constants. */
1130 while (p && !(p->iterator
1131 || p->expr->expr_type != EXPR_CONSTANT))
1133 gfc_init_se (&se, NULL);
1134 gfc_conv_constant (&se, p->expr);
1135 if (p->expr->ts.type == BT_CHARACTER
1136 && POINTER_TYPE_P (type))
1138 /* For constant character array constructors we build
1139 an array of pointers. */
1140 se.expr = gfc_build_addr_expr (pchar_type_node,
1144 list = tree_cons (NULL_TREE, se.expr, list);
1149 bound = build_int_cst (NULL_TREE, n - 1);
1150 /* Create an array type to hold them. */
1151 tmptype = build_range_type (gfc_array_index_type,
1152 gfc_index_zero_node, bound);
1153 tmptype = build_array_type (type, tmptype);
1155 init = build_constructor_from_list (tmptype, nreverse (list));
1156 TREE_CONSTANT (init) = 1;
1157 TREE_INVARIANT (init) = 1;
1158 TREE_STATIC (init) = 1;
1159 /* Create a static variable to hold the data. */
1160 tmp = gfc_create_var (tmptype, "data");
1161 TREE_STATIC (tmp) = 1;
1162 TREE_CONSTANT (tmp) = 1;
1163 TREE_INVARIANT (tmp) = 1;
1164 DECL_INITIAL (tmp) = init;
1167 /* Use BUILTIN_MEMCPY to assign the values. */
1168 tmp = gfc_conv_descriptor_data_get (desc);
1169 tmp = build_fold_indirect_ref (tmp);
1170 tmp = gfc_build_array_ref (tmp, *poffset);
1171 tmp = build_fold_addr_expr (tmp);
1172 init = build_fold_addr_expr (init);
1174 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1175 bound = build_int_cst (NULL_TREE, n * size);
1176 tmp = gfc_chainon_list (NULL_TREE, tmp);
1177 tmp = gfc_chainon_list (tmp, init);
1178 tmp = gfc_chainon_list (tmp, bound);
1179 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1181 gfc_add_expr_to_block (&body, tmp);
1183 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1184 *poffset, build_int_cst (NULL_TREE, n));
1186 if (!INTEGER_CST_P (*poffset))
1188 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1189 *poffset = *offsetvar;
1193 /* The frontend should already have done any expansions possible
1197 /* Pass the code as is. */
1198 tmp = gfc_finish_block (&body);
1199 gfc_add_expr_to_block (pblock, tmp);
1203 /* Build the implied do-loop. */
1212 loopbody = gfc_finish_block (&body);
1214 gfc_init_se (&se, NULL);
1215 gfc_conv_expr (&se, c->iterator->var);
1216 gfc_add_block_to_block (pblock, &se.pre);
1219 /* Initialize the loop. */
1220 gfc_init_se (&se, NULL);
1221 gfc_conv_expr_val (&se, c->iterator->start);
1222 gfc_add_block_to_block (pblock, &se.pre);
1223 gfc_add_modify_expr (pblock, loopvar, se.expr);
1225 gfc_init_se (&se, NULL);
1226 gfc_conv_expr_val (&se, c->iterator->end);
1227 gfc_add_block_to_block (pblock, &se.pre);
1228 end = gfc_evaluate_now (se.expr, pblock);
1230 gfc_init_se (&se, NULL);
1231 gfc_conv_expr_val (&se, c->iterator->step);
1232 gfc_add_block_to_block (pblock, &se.pre);
1233 step = gfc_evaluate_now (se.expr, pblock);
1235 /* If this array expands dynamically, and the number of iterations
1236 is not constant, we won't have allocated space for the static
1237 part of C->EXPR's size. Do that now. */
1238 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1240 /* Get the number of iterations. */
1241 tmp = gfc_get_iteration_count (loopvar, end, step);
1243 /* Get the static part of C->EXPR's size. */
1244 gfc_get_array_constructor_element_size (&size, c->expr);
1245 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1247 /* Grow the array by TMP * TMP2 elements. */
1248 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1249 gfc_grow_array (pblock, desc, tmp);
1252 /* Generate the loop body. */
1253 exit_label = gfc_build_label_decl (NULL_TREE);
1254 gfc_start_block (&body);
1256 /* Generate the exit condition. Depending on the sign of
1257 the step variable we have to generate the correct
1259 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1260 build_int_cst (TREE_TYPE (step), 0));
1261 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1262 build2 (GT_EXPR, boolean_type_node,
1264 build2 (LT_EXPR, boolean_type_node,
1266 tmp = build1_v (GOTO_EXPR, exit_label);
1267 TREE_USED (exit_label) = 1;
1268 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1269 gfc_add_expr_to_block (&body, tmp);
1271 /* The main loop body. */
1272 gfc_add_expr_to_block (&body, loopbody);
1274 /* Increase loop variable by step. */
1275 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1276 gfc_add_modify_expr (&body, loopvar, tmp);
1278 /* Finish the loop. */
1279 tmp = gfc_finish_block (&body);
1280 tmp = build1_v (LOOP_EXPR, tmp);
1281 gfc_add_expr_to_block (pblock, tmp);
1283 /* Add the exit label. */
1284 tmp = build1_v (LABEL_EXPR, exit_label);
1285 gfc_add_expr_to_block (pblock, tmp);
1292 /* Figure out the string length of a variable reference expression.
1293 Used by get_array_ctor_strlen. */
1296 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1301 /* Don't bother if we already know the length is a constant. */
1302 if (*len && INTEGER_CST_P (*len))
1305 ts = &expr->symtree->n.sym->ts;
1306 for (ref = expr->ref; ref; ref = ref->next)
1311 /* Array references don't change the string length. */
1315 /* Use the length of the component. */
1316 ts = &ref->u.c.component->ts;
1320 /* TODO: Substrings are tricky because we can't evaluate the
1321 expression more than once. For now we just give up, and hope
1322 we can figure it out elsewhere. */
1327 *len = ts->cl->backend_decl;
1331 /* Figure out the string length of a character array constructor.
1332 Returns TRUE if all elements are character constants. */
1335 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1340 for (; c; c = c->next)
1342 switch (c->expr->expr_type)
1345 if (!(*len && INTEGER_CST_P (*len)))
1346 *len = build_int_cstu (gfc_charlen_type_node,
1347 c->expr->value.character.length);
1351 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1357 get_array_ctor_var_strlen (c->expr, len);
1362 /* TODO: For now we just ignore anything we don't know how to
1363 handle, and hope we can figure it out a different way. */
1372 /* Array constructors are handled by constructing a temporary, then using that
1373 within the scalarization loop. This is not optimal, but seems by far the
1377 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1387 ss->data.info.dimen = loop->dimen;
1389 c = ss->expr->value.constructor;
1390 if (ss->expr->ts.type == BT_CHARACTER)
1392 const_string = get_array_ctor_strlen (c, &ss->string_length);
1393 if (!ss->string_length)
1394 gfc_todo_error ("complex character array constructors");
1396 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1398 type = build_pointer_type (type);
1402 const_string = TRUE;
1403 type = gfc_typenode_for_spec (&ss->expr->ts);
1406 /* See if the constructor determines the loop bounds. */
1408 if (loop->to[0] == NULL_TREE)
1412 /* We should have a 1-dimensional, zero-based loop. */
1413 gcc_assert (loop->dimen == 1);
1414 gcc_assert (integer_zerop (loop->from[0]));
1416 /* Split the constructor size into a static part and a dynamic part.
1417 Allocate the static size up-front and record whether the dynamic
1418 size might be nonzero. */
1420 dynamic = gfc_get_array_constructor_size (&size, c);
1421 mpz_sub_ui (size, size, 1);
1422 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1426 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1427 type, dynamic, true, false);
1429 desc = ss->data.info.descriptor;
1430 offset = gfc_index_zero_node;
1431 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1432 TREE_USED (offsetvar) = 0;
1433 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1434 &offset, &offsetvar, dynamic);
1436 /* If the array grows dynamically, the upper bound of the loop variable
1437 is determined by the array's final upper bound. */
1439 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1441 if (TREE_USED (offsetvar))
1442 pushdecl (offsetvar);
1444 gcc_assert (INTEGER_CST_P (offset));
1446 /* Disable bound checking for now because it's probably broken. */
1447 if (flag_bounds_check)
1455 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1456 called after evaluating all of INFO's vector dimensions. Go through
1457 each such vector dimension and see if we can now fill in any missing
1461 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1470 for (n = 0; n < loop->dimen; n++)
1473 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1474 && loop->to[n] == NULL)
1476 /* Loop variable N indexes vector dimension DIM, and we don't
1477 yet know the upper bound of loop variable N. Set it to the
1478 difference between the vector's upper and lower bounds. */
1479 gcc_assert (loop->from[n] == gfc_index_zero_node);
1480 gcc_assert (info->subscript[dim]
1481 && info->subscript[dim]->type == GFC_SS_VECTOR);
1483 gfc_init_se (&se, NULL);
1484 desc = info->subscript[dim]->data.info.descriptor;
1485 zero = gfc_rank_cst[0];
1486 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1487 gfc_conv_descriptor_ubound (desc, zero),
1488 gfc_conv_descriptor_lbound (desc, zero));
1489 tmp = gfc_evaluate_now (tmp, &loop->pre);
1496 /* Add the pre and post chains for all the scalar expressions in a SS chain
1497 to loop. This is called after the loop parameters have been calculated,
1498 but before the actual scalarizing loops. */
1501 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1506 /* TODO: This can generate bad code if there are ordering dependencies.
1507 eg. a callee allocated function and an unknown size constructor. */
1508 gcc_assert (ss != NULL);
1510 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1517 /* Scalar expression. Evaluate this now. This includes elemental
1518 dimension indices, but not array section bounds. */
1519 gfc_init_se (&se, NULL);
1520 gfc_conv_expr (&se, ss->expr);
1521 gfc_add_block_to_block (&loop->pre, &se.pre);
1523 if (ss->expr->ts.type != BT_CHARACTER)
1525 /* Move the evaluation of scalar expressions outside the
1526 scalarization loop. */
1528 se.expr = convert(gfc_array_index_type, se.expr);
1529 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1530 gfc_add_block_to_block (&loop->pre, &se.post);
1533 gfc_add_block_to_block (&loop->post, &se.post);
1535 ss->data.scalar.expr = se.expr;
1536 ss->string_length = se.string_length;
1539 case GFC_SS_REFERENCE:
1540 /* Scalar reference. Evaluate this now. */
1541 gfc_init_se (&se, NULL);
1542 gfc_conv_expr_reference (&se, ss->expr);
1543 gfc_add_block_to_block (&loop->pre, &se.pre);
1544 gfc_add_block_to_block (&loop->post, &se.post);
1546 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1547 ss->string_length = se.string_length;
1550 case GFC_SS_SECTION:
1551 /* Add the expressions for scalar and vector subscripts. */
1552 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1553 if (ss->data.info.subscript[n])
1554 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1556 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1560 /* Get the vector's descriptor and store it in SS. */
1561 gfc_init_se (&se, NULL);
1562 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1563 gfc_add_block_to_block (&loop->pre, &se.pre);
1564 gfc_add_block_to_block (&loop->post, &se.post);
1565 ss->data.info.descriptor = se.expr;
1568 case GFC_SS_INTRINSIC:
1569 gfc_add_intrinsic_ss_code (loop, ss);
1572 case GFC_SS_FUNCTION:
1573 /* Array function return value. We call the function and save its
1574 result in a temporary for use inside the loop. */
1575 gfc_init_se (&se, NULL);
1578 gfc_conv_expr (&se, ss->expr);
1579 gfc_add_block_to_block (&loop->pre, &se.pre);
1580 gfc_add_block_to_block (&loop->post, &se.post);
1581 ss->string_length = se.string_length;
1584 case GFC_SS_CONSTRUCTOR:
1585 gfc_trans_array_constructor (loop, ss);
1589 case GFC_SS_COMPONENT:
1590 /* Do nothing. These are handled elsewhere. */
1600 /* Translate expressions for the descriptor and data pointer of a SS. */
1604 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1609 /* Get the descriptor for the array to be scalarized. */
1610 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1611 gfc_init_se (&se, NULL);
1612 se.descriptor_only = 1;
1613 gfc_conv_expr_lhs (&se, ss->expr);
1614 gfc_add_block_to_block (block, &se.pre);
1615 ss->data.info.descriptor = se.expr;
1616 ss->string_length = se.string_length;
1620 /* Also the data pointer. */
1621 tmp = gfc_conv_array_data (se.expr);
1622 /* If this is a variable or address of a variable we use it directly.
1623 Otherwise we must evaluate it now to avoid breaking dependency
1624 analysis by pulling the expressions for elemental array indices
1627 || (TREE_CODE (tmp) == ADDR_EXPR
1628 && DECL_P (TREE_OPERAND (tmp, 0)))))
1629 tmp = gfc_evaluate_now (tmp, block);
1630 ss->data.info.data = tmp;
1632 tmp = gfc_conv_array_offset (se.expr);
1633 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1638 /* Initialize a gfc_loopinfo structure. */
1641 gfc_init_loopinfo (gfc_loopinfo * loop)
1645 memset (loop, 0, sizeof (gfc_loopinfo));
1646 gfc_init_block (&loop->pre);
1647 gfc_init_block (&loop->post);
1649 /* Initially scalarize in order. */
1650 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1653 loop->ss = gfc_ss_terminator;
1657 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1661 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1667 /* Return an expression for the data pointer of an array. */
1670 gfc_conv_array_data (tree descriptor)
1674 type = TREE_TYPE (descriptor);
1675 if (GFC_ARRAY_TYPE_P (type))
1677 if (TREE_CODE (type) == POINTER_TYPE)
1681 /* Descriptorless arrays. */
1682 return build_fold_addr_expr (descriptor);
1686 return gfc_conv_descriptor_data_get (descriptor);
1690 /* Return an expression for the base offset of an array. */
1693 gfc_conv_array_offset (tree descriptor)
1697 type = TREE_TYPE (descriptor);
1698 if (GFC_ARRAY_TYPE_P (type))
1699 return GFC_TYPE_ARRAY_OFFSET (type);
1701 return gfc_conv_descriptor_offset (descriptor);
1705 /* Get an expression for the array stride. */
1708 gfc_conv_array_stride (tree descriptor, int dim)
1713 type = TREE_TYPE (descriptor);
1715 /* For descriptorless arrays use the array size. */
1716 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1717 if (tmp != NULL_TREE)
1720 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1725 /* Like gfc_conv_array_stride, but for the lower bound. */
1728 gfc_conv_array_lbound (tree descriptor, int dim)
1733 type = TREE_TYPE (descriptor);
1735 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1736 if (tmp != NULL_TREE)
1739 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1744 /* Like gfc_conv_array_stride, but for the upper bound. */
1747 gfc_conv_array_ubound (tree descriptor, int dim)
1752 type = TREE_TYPE (descriptor);
1754 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1755 if (tmp != NULL_TREE)
1758 /* This should only ever happen when passing an assumed shape array
1759 as an actual parameter. The value will never be used. */
1760 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1761 return gfc_index_zero_node;
1763 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1768 /* Generate code to perform an array index bound check. */
1771 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1777 if (!flag_bounds_check)
1780 index = gfc_evaluate_now (index, &se->pre);
1781 /* Check lower bound. */
1782 tmp = gfc_conv_array_lbound (descriptor, n);
1783 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1784 /* Check upper bound. */
1785 tmp = gfc_conv_array_ubound (descriptor, n);
1786 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1787 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1789 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1795 /* Return the offset for an index. Performs bound checking for elemental
1796 dimensions. Single element references are processed separately. */
1799 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1800 gfc_array_ref * ar, tree stride)
1806 /* Get the index into the array for this dimension. */
1809 gcc_assert (ar->type != AR_ELEMENT);
1810 switch (ar->dimen_type[dim])
1813 gcc_assert (i == -1);
1814 /* Elemental dimension. */
1815 gcc_assert (info->subscript[dim]
1816 && info->subscript[dim]->type == GFC_SS_SCALAR);
1817 /* We've already translated this value outside the loop. */
1818 index = info->subscript[dim]->data.scalar.expr;
1821 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1825 gcc_assert (info && se->loop);
1826 gcc_assert (info->subscript[dim]
1827 && info->subscript[dim]->type == GFC_SS_VECTOR);
1828 desc = info->subscript[dim]->data.info.descriptor;
1830 /* Get a zero-based index into the vector. */
1831 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1832 se->loop->loopvar[i], se->loop->from[i]);
1834 /* Multiply the index by the stride. */
1835 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1836 index, gfc_conv_array_stride (desc, 0));
1838 /* Read the vector to get an index into info->descriptor. */
1839 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1840 index = gfc_build_array_ref (data, index);
1841 index = gfc_evaluate_now (index, &se->pre);
1843 /* Do any bounds checking on the final info->descriptor index. */
1844 index = gfc_trans_array_bound_check (se, info->descriptor,
1849 /* Scalarized dimension. */
1850 gcc_assert (info && se->loop);
1852 /* Multiply the loop variable by the stride and delta. */
1853 index = se->loop->loopvar[i];
1854 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1856 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1866 /* Temporary array or derived type component. */
1867 gcc_assert (se->loop);
1868 index = se->loop->loopvar[se->loop->order[i]];
1869 if (!integer_zerop (info->delta[i]))
1870 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1871 index, info->delta[i]);
1874 /* Multiply by the stride. */
1875 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1881 /* Build a scalarized reference to an array. */
1884 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1891 info = &se->ss->data.info;
1893 n = se->loop->order[0];
1897 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1899 /* Add the offset for this dimension to the stored offset for all other
1901 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1903 tmp = build_fold_indirect_ref (info->data);
1904 se->expr = gfc_build_array_ref (tmp, index);
1908 /* Translate access of temporary array. */
1911 gfc_conv_tmp_array_ref (gfc_se * se)
1913 se->string_length = se->ss->string_length;
1914 gfc_conv_scalarized_array_ref (se, NULL);
1918 /* Build an array reference. se->expr already holds the array descriptor.
1919 This should be either a variable, indirect variable reference or component
1920 reference. For arrays which do not have a descriptor, se->expr will be
1922 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1925 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1934 /* Handle scalarized references separately. */
1935 if (ar->type != AR_ELEMENT)
1937 gfc_conv_scalarized_array_ref (se, ar);
1938 gfc_advance_se_ss_chain (se);
1942 index = gfc_index_zero_node;
1944 fault = gfc_index_zero_node;
1946 /* Calculate the offsets from all the dimensions. */
1947 for (n = 0; n < ar->dimen; n++)
1949 /* Calculate the index for this dimension. */
1950 gfc_init_se (&indexse, se);
1951 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1952 gfc_add_block_to_block (&se->pre, &indexse.pre);
1954 if (flag_bounds_check)
1956 /* Check array bounds. */
1959 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1961 tmp = gfc_conv_array_lbound (se->expr, n);
1962 cond = fold_build2 (LT_EXPR, boolean_type_node,
1965 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1967 tmp = gfc_conv_array_ubound (se->expr, n);
1968 cond = fold_build2 (GT_EXPR, boolean_type_node,
1971 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1974 /* Multiply the index by the stride. */
1975 stride = gfc_conv_array_stride (se->expr, n);
1976 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1979 /* And add it to the total. */
1980 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1983 if (flag_bounds_check)
1984 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1986 tmp = gfc_conv_array_offset (se->expr);
1987 if (!integer_zerop (tmp))
1988 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1990 /* Access the calculated element. */
1991 tmp = gfc_conv_array_data (se->expr);
1992 tmp = build_fold_indirect_ref (tmp);
1993 se->expr = gfc_build_array_ref (tmp, index);
1997 /* Generate the code to be executed immediately before entering a
1998 scalarization loop. */
2001 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2002 stmtblock_t * pblock)
2011 /* This code will be executed before entering the scalarization loop
2012 for this dimension. */
2013 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2015 if ((ss->useflags & flag) == 0)
2018 if (ss->type != GFC_SS_SECTION
2019 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2020 && ss->type != GFC_SS_COMPONENT)
2023 info = &ss->data.info;
2025 if (dim >= info->dimen)
2028 if (dim == info->dimen - 1)
2030 /* For the outermost loop calculate the offset due to any
2031 elemental dimensions. It will have been initialized with the
2032 base offset of the array. */
2035 for (i = 0; i < info->ref->u.ar.dimen; i++)
2037 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2040 gfc_init_se (&se, NULL);
2042 se.expr = info->descriptor;
2043 stride = gfc_conv_array_stride (info->descriptor, i);
2044 index = gfc_conv_array_index_offset (&se, info, i, -1,
2047 gfc_add_block_to_block (pblock, &se.pre);
2049 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2050 info->offset, index);
2051 info->offset = gfc_evaluate_now (info->offset, pblock);
2055 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2058 stride = gfc_conv_array_stride (info->descriptor, 0);
2060 /* Calculate the stride of the innermost loop. Hopefully this will
2061 allow the backend optimizers to do their stuff more effectively.
2063 info->stride0 = gfc_evaluate_now (stride, pblock);
2067 /* Add the offset for the previous loop dimension. */
2072 ar = &info->ref->u.ar;
2073 i = loop->order[dim + 1];
2081 gfc_init_se (&se, NULL);
2083 se.expr = info->descriptor;
2084 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2085 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2087 gfc_add_block_to_block (pblock, &se.pre);
2088 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2089 info->offset, index);
2090 info->offset = gfc_evaluate_now (info->offset, pblock);
2093 /* Remember this offset for the second loop. */
2094 if (dim == loop->temp_dim - 1)
2095 info->saved_offset = info->offset;
2100 /* Start a scalarized expression. Creates a scope and declares loop
2104 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2110 gcc_assert (!loop->array_parameter);
2112 for (dim = loop->dimen - 1; dim >= 0; dim--)
2114 n = loop->order[dim];
2116 gfc_start_block (&loop->code[n]);
2118 /* Create the loop variable. */
2119 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2121 if (dim < loop->temp_dim)
2125 /* Calculate values that will be constant within this loop. */
2126 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2128 gfc_start_block (pbody);
2132 /* Generates the actual loop code for a scalarization loop. */
2135 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2136 stmtblock_t * pbody)
2144 loopbody = gfc_finish_block (pbody);
2146 /* Initialize the loopvar. */
2147 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2149 exit_label = gfc_build_label_decl (NULL_TREE);
2151 /* Generate the loop body. */
2152 gfc_init_block (&block);
2154 /* The exit condition. */
2155 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2156 tmp = build1_v (GOTO_EXPR, exit_label);
2157 TREE_USED (exit_label) = 1;
2158 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2159 gfc_add_expr_to_block (&block, tmp);
2161 /* The main body. */
2162 gfc_add_expr_to_block (&block, loopbody);
2164 /* Increment the loopvar. */
2165 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2166 loop->loopvar[n], gfc_index_one_node);
2167 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2169 /* Build the loop. */
2170 tmp = gfc_finish_block (&block);
2171 tmp = build1_v (LOOP_EXPR, tmp);
2172 gfc_add_expr_to_block (&loop->code[n], tmp);
2174 /* Add the exit label. */
2175 tmp = build1_v (LABEL_EXPR, exit_label);
2176 gfc_add_expr_to_block (&loop->code[n], tmp);
2180 /* Finishes and generates the loops for a scalarized expression. */
2183 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2188 stmtblock_t *pblock;
2192 /* Generate the loops. */
2193 for (dim = 0; dim < loop->dimen; dim++)
2195 n = loop->order[dim];
2196 gfc_trans_scalarized_loop_end (loop, n, pblock);
2197 loop->loopvar[n] = NULL_TREE;
2198 pblock = &loop->code[n];
2201 tmp = gfc_finish_block (pblock);
2202 gfc_add_expr_to_block (&loop->pre, tmp);
2204 /* Clear all the used flags. */
2205 for (ss = loop->ss; ss; ss = ss->loop_chain)
2210 /* Finish the main body of a scalarized expression, and start the secondary
2214 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2218 stmtblock_t *pblock;
2222 /* We finish as many loops as are used by the temporary. */
2223 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2225 n = loop->order[dim];
2226 gfc_trans_scalarized_loop_end (loop, n, pblock);
2227 loop->loopvar[n] = NULL_TREE;
2228 pblock = &loop->code[n];
2231 /* We don't want to finish the outermost loop entirely. */
2232 n = loop->order[loop->temp_dim - 1];
2233 gfc_trans_scalarized_loop_end (loop, n, pblock);
2235 /* Restore the initial offsets. */
2236 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2238 if ((ss->useflags & 2) == 0)
2241 if (ss->type != GFC_SS_SECTION
2242 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2243 && ss->type != GFC_SS_COMPONENT)
2246 ss->data.info.offset = ss->data.info.saved_offset;
2249 /* Restart all the inner loops we just finished. */
2250 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2252 n = loop->order[dim];
2254 gfc_start_block (&loop->code[n]);
2256 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2258 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2261 /* Start a block for the secondary copying code. */
2262 gfc_start_block (body);
2266 /* Calculate the upper bound of an array section. */
2269 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2278 gcc_assert (ss->type == GFC_SS_SECTION);
2280 info = &ss->data.info;
2283 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2284 /* We'll calculate the upper bound once we have access to the
2285 vector's descriptor. */
2288 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2289 desc = info->descriptor;
2290 end = info->ref->u.ar.end[dim];
2294 /* The upper bound was specified. */
2295 gfc_init_se (&se, NULL);
2296 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2297 gfc_add_block_to_block (pblock, &se.pre);
2302 /* No upper bound was specified, so use the bound of the array. */
2303 bound = gfc_conv_array_ubound (desc, dim);
2310 /* Calculate the lower bound of an array section. */
2313 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2322 gcc_assert (ss->type == GFC_SS_SECTION);
2324 info = &ss->data.info;
2327 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2329 /* We use a zero-based index to access the vector. */
2330 info->start[n] = gfc_index_zero_node;
2331 info->stride[n] = gfc_index_one_node;
2335 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2336 desc = info->descriptor;
2337 start = info->ref->u.ar.start[dim];
2338 stride = info->ref->u.ar.stride[dim];
2340 /* Calculate the start of the range. For vector subscripts this will
2341 be the range of the vector. */
2344 /* Specified section start. */
2345 gfc_init_se (&se, NULL);
2346 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2347 gfc_add_block_to_block (&loop->pre, &se.pre);
2348 info->start[n] = se.expr;
2352 /* No lower bound specified so use the bound of the array. */
2353 info->start[n] = gfc_conv_array_lbound (desc, dim);
2355 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2357 /* Calculate the stride. */
2359 info->stride[n] = gfc_index_one_node;
2362 gfc_init_se (&se, NULL);
2363 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2364 gfc_add_block_to_block (&loop->pre, &se.pre);
2365 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2370 /* Calculates the range start and stride for a SS chain. Also gets the
2371 descriptor and data pointer. The range of vector subscripts is the size
2372 of the vector. Array bounds are also checked. */
2375 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2383 /* Determine the rank of the loop. */
2385 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2389 case GFC_SS_SECTION:
2390 case GFC_SS_CONSTRUCTOR:
2391 case GFC_SS_FUNCTION:
2392 case GFC_SS_COMPONENT:
2393 loop->dimen = ss->data.info.dimen;
2396 /* As usual, lbound and ubound are exceptions!. */
2397 case GFC_SS_INTRINSIC:
2398 switch (ss->expr->value.function.isym->generic_id)
2400 case GFC_ISYM_LBOUND:
2401 case GFC_ISYM_UBOUND:
2402 loop->dimen = ss->data.info.dimen;
2413 if (loop->dimen == 0)
2414 gfc_todo_error ("Unable to determine rank of expression");
2417 /* Loop over all the SS in the chain. */
2418 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2420 if (ss->expr && ss->expr->shape && !ss->shape)
2421 ss->shape = ss->expr->shape;
2425 case GFC_SS_SECTION:
2426 /* Get the descriptor for the array. */
2427 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2429 for (n = 0; n < ss->data.info.dimen; n++)
2430 gfc_conv_section_startstride (loop, ss, n);
2433 case GFC_SS_INTRINSIC:
2434 switch (ss->expr->value.function.isym->generic_id)
2436 /* Fall through to supply start and stride. */
2437 case GFC_ISYM_LBOUND:
2438 case GFC_ISYM_UBOUND:
2444 case GFC_SS_CONSTRUCTOR:
2445 case GFC_SS_FUNCTION:
2446 for (n = 0; n < ss->data.info.dimen; n++)
2448 ss->data.info.start[n] = gfc_index_zero_node;
2449 ss->data.info.stride[n] = gfc_index_one_node;
2458 /* The rest is just runtime bound checking. */
2459 if (flag_bounds_check)
2465 tree size[GFC_MAX_DIMENSIONS];
2469 gfc_start_block (&block);
2471 fault = boolean_false_node;
2472 for (n = 0; n < loop->dimen; n++)
2473 size[n] = NULL_TREE;
2475 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2477 if (ss->type != GFC_SS_SECTION)
2480 /* TODO: range checking for mapped dimensions. */
2481 info = &ss->data.info;
2483 /* This code only checks ranges. Elemental and vector
2484 dimensions are checked later. */
2485 for (n = 0; n < loop->dimen; n++)
2488 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2491 desc = ss->data.info.descriptor;
2493 /* Check lower bound. */
2494 bound = gfc_conv_array_lbound (desc, dim);
2495 tmp = info->start[n];
2496 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2497 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2500 /* Check the upper bound. */
2501 bound = gfc_conv_array_ubound (desc, dim);
2502 end = gfc_conv_section_upper_bound (ss, n, &block);
2503 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2504 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2507 /* Check the section sizes match. */
2508 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2510 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2512 /* We remember the size of the first section, and check all the
2513 others against this. */
2517 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2519 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2522 size[n] = gfc_evaluate_now (tmp, &block);
2525 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2527 tmp = gfc_finish_block (&block);
2528 gfc_add_expr_to_block (&loop->pre, tmp);
2533 /* Return true if the two SS could be aliased, i.e. both point to the same data
2535 /* TODO: resolve aliases based on frontend expressions. */
2538 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2545 lsym = lss->expr->symtree->n.sym;
2546 rsym = rss->expr->symtree->n.sym;
2547 if (gfc_symbols_could_alias (lsym, rsym))
2550 if (rsym->ts.type != BT_DERIVED
2551 && lsym->ts.type != BT_DERIVED)
2554 /* For derived types we must check all the component types. We can ignore
2555 array references as these will have the same base type as the previous
2557 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2559 if (lref->type != REF_COMPONENT)
2562 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2565 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2568 if (rref->type != REF_COMPONENT)
2571 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2576 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2578 if (rref->type != REF_COMPONENT)
2581 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2589 /* Resolve array data dependencies. Creates a temporary if required. */
2590 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2594 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2604 loop->temp_ss = NULL;
2605 aref = dest->data.info.ref;
2608 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2610 if (ss->type != GFC_SS_SECTION)
2613 if (gfc_could_be_alias (dest, ss)
2614 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2620 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2622 lref = dest->expr->ref;
2623 rref = ss->expr->ref;
2625 nDepend = gfc_dep_resolver (lref, rref);
2627 /* TODO : loop shifting. */
2630 /* Mark the dimensions for LOOP SHIFTING */
2631 for (n = 0; n < loop->dimen; n++)
2633 int dim = dest->data.info.dim[n];
2635 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2637 else if (! gfc_is_same_range (&lref->u.ar,
2638 &rref->u.ar, dim, 0))
2642 /* Put all the dimensions with dependencies in the
2645 for (n = 0; n < loop->dimen; n++)
2647 gcc_assert (loop->order[n] == n);
2649 loop->order[dim++] = n;
2652 for (n = 0; n < loop->dimen; n++)
2655 loop->order[dim++] = n;
2658 gcc_assert (dim == loop->dimen);
2667 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2668 if (GFC_ARRAY_TYPE_P (base_type)
2669 || GFC_DESCRIPTOR_TYPE_P (base_type))
2670 base_type = gfc_get_element_type (base_type);
2671 loop->temp_ss = gfc_get_ss ();
2672 loop->temp_ss->type = GFC_SS_TEMP;
2673 loop->temp_ss->data.temp.type = base_type;
2674 loop->temp_ss->string_length = dest->string_length;
2675 loop->temp_ss->data.temp.dimen = loop->dimen;
2676 loop->temp_ss->next = gfc_ss_terminator;
2677 gfc_add_ss_to_loop (loop, loop->temp_ss);
2680 loop->temp_ss = NULL;
2684 /* Initialize the scalarization loop. Creates the loop variables. Determines
2685 the range of the loop variables. Creates a temporary if required.
2686 Calculates how to transform from loop variables to array indices for each
2687 expression. Also generates code for scalar expressions which have been
2688 moved outside the loop. */
2691 gfc_conv_loop_setup (gfc_loopinfo * loop)
2696 gfc_ss_info *specinfo;
2700 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2701 bool dynamic[GFC_MAX_DIMENSIONS];
2707 for (n = 0; n < loop->dimen; n++)
2711 /* We use one SS term, and use that to determine the bounds of the
2712 loop for this dimension. We try to pick the simplest term. */
2713 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2717 /* The frontend has worked out the size for us. */
2722 if (ss->type == GFC_SS_CONSTRUCTOR)
2724 /* An unknown size constructor will always be rank one.
2725 Higher rank constructors will either have known shape,
2726 or still be wrapped in a call to reshape. */
2727 gcc_assert (loop->dimen == 1);
2729 /* Always prefer to use the constructor bounds if the size
2730 can be determined at compile time. Prefer not to otherwise,
2731 since the general case involves realloc, and it's better to
2732 avoid that overhead if possible. */
2733 c = ss->expr->value.constructor;
2734 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2735 if (!dynamic[n] || !loopspec[n])
2740 /* TODO: Pick the best bound if we have a choice between a
2741 function and something else. */
2742 if (ss->type == GFC_SS_FUNCTION)
2748 if (ss->type != GFC_SS_SECTION)
2752 specinfo = &loopspec[n]->data.info;
2755 info = &ss->data.info;
2759 /* Criteria for choosing a loop specifier (most important first):
2760 doesn't need realloc
2766 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2768 else if (integer_onep (info->stride[n])
2769 && !integer_onep (specinfo->stride[n]))
2771 else if (INTEGER_CST_P (info->stride[n])
2772 && !INTEGER_CST_P (specinfo->stride[n]))
2774 else if (INTEGER_CST_P (info->start[n])
2775 && !INTEGER_CST_P (specinfo->start[n]))
2777 /* We don't work out the upper bound.
2778 else if (INTEGER_CST_P (info->finish[n])
2779 && ! INTEGER_CST_P (specinfo->finish[n]))
2780 loopspec[n] = ss; */
2784 gfc_todo_error ("Unable to find scalarization loop specifier");
2786 info = &loopspec[n]->data.info;
2788 /* Set the extents of this range. */
2789 cshape = loopspec[n]->shape;
2790 if (cshape && INTEGER_CST_P (info->start[n])
2791 && INTEGER_CST_P (info->stride[n]))
2793 loop->from[n] = info->start[n];
2794 mpz_set (i, cshape[n]);
2795 mpz_sub_ui (i, i, 1);
2796 /* To = from + (size - 1) * stride. */
2797 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2798 if (!integer_onep (info->stride[n]))
2799 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2800 tmp, info->stride[n]);
2801 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2802 loop->from[n], tmp);
2806 loop->from[n] = info->start[n];
2807 switch (loopspec[n]->type)
2809 case GFC_SS_CONSTRUCTOR:
2810 /* The upper bound is calculated when we expand the
2812 gcc_assert (loop->to[n] == NULL_TREE);
2815 case GFC_SS_SECTION:
2816 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2820 case GFC_SS_FUNCTION:
2821 /* The loop bound will be set when we generate the call. */
2822 gcc_assert (loop->to[n] == NULL_TREE);
2830 /* Transform everything so we have a simple incrementing variable. */
2831 if (integer_onep (info->stride[n]))
2832 info->delta[n] = gfc_index_zero_node;
2835 /* Set the delta for this section. */
2836 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2837 /* Number of iterations is (end - start + step) / step.
2838 with start = 0, this simplifies to
2840 for (i = 0; i<=last; i++){...}; */
2841 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2842 loop->to[n], loop->from[n]);
2843 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2844 tmp, info->stride[n]);
2845 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2846 /* Make the loop variable start at 0. */
2847 loop->from[n] = gfc_index_zero_node;
2851 /* Add all the scalar code that can be taken out of the loops.
2852 This may include calculating the loop bounds, so do it before
2853 allocating the temporary. */
2854 gfc_add_loop_ss_code (loop, loop->ss, false);
2856 /* If we want a temporary then create it. */
2857 if (loop->temp_ss != NULL)
2859 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2860 tmp = loop->temp_ss->data.temp.type;
2861 len = loop->temp_ss->string_length;
2862 n = loop->temp_ss->data.temp.dimen;
2863 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2864 loop->temp_ss->type = GFC_SS_SECTION;
2865 loop->temp_ss->data.info.dimen = n;
2866 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
2867 &loop->temp_ss->data.info, tmp, false, true,
2871 for (n = 0; n < loop->temp_dim; n++)
2872 loopspec[loop->order[n]] = NULL;
2876 /* For array parameters we don't have loop variables, so don't calculate the
2878 if (loop->array_parameter)
2881 /* Calculate the translation from loop variables to array indices. */
2882 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2884 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2887 info = &ss->data.info;
2889 for (n = 0; n < info->dimen; n++)
2893 /* If we are specifying the range the delta is already set. */
2894 if (loopspec[n] != ss)
2896 /* Calculate the offset relative to the loop variable.
2897 First multiply by the stride. */
2898 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2899 loop->from[n], info->stride[n]);
2901 /* Then subtract this from our starting value. */
2902 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2903 info->start[n], tmp);
2905 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2912 /* Fills in an array descriptor, and returns the size of the array. The size
2913 will be a simple_val, ie a variable or a constant. Also calculates the
2914 offset of the base. Returns the size of the array.
2918 for (n = 0; n < rank; n++)
2920 a.lbound[n] = specified_lower_bound;
2921 offset = offset + a.lbond[n] * stride;
2923 a.ubound[n] = specified_upper_bound;
2924 a.stride[n] = stride;
2925 size = ubound + size; //size = ubound + 1 - lbound
2926 stride = stride * size;
2933 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2934 gfc_expr ** lower, gfc_expr ** upper,
2935 stmtblock_t * pblock)
2946 type = TREE_TYPE (descriptor);
2948 stride = gfc_index_one_node;
2949 offset = gfc_index_zero_node;
2951 /* Set the dtype. */
2952 tmp = gfc_conv_descriptor_dtype (descriptor);
2953 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2955 for (n = 0; n < rank; n++)
2957 /* We have 3 possibilities for determining the size of the array:
2958 lower == NULL => lbound = 1, ubound = upper[n]
2959 upper[n] = NULL => lbound = 1, ubound = lower[n]
2960 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2963 /* Set lower bound. */
2964 gfc_init_se (&se, NULL);
2966 se.expr = gfc_index_one_node;
2969 gcc_assert (lower[n]);
2972 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2973 gfc_add_block_to_block (pblock, &se.pre);
2977 se.expr = gfc_index_one_node;
2981 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2982 gfc_add_modify_expr (pblock, tmp, se.expr);
2984 /* Work out the offset for this component. */
2985 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2986 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2988 /* Start the calculation for the size of this dimension. */
2989 size = build2 (MINUS_EXPR, gfc_array_index_type,
2990 gfc_index_one_node, se.expr);
2992 /* Set upper bound. */
2993 gfc_init_se (&se, NULL);
2994 gcc_assert (ubound);
2995 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2996 gfc_add_block_to_block (pblock, &se.pre);
2998 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2999 gfc_add_modify_expr (pblock, tmp, se.expr);
3001 /* Store the stride. */
3002 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3003 gfc_add_modify_expr (pblock, tmp, stride);
3005 /* Calculate the size of this dimension. */
3006 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3008 /* Multiply the stride by the number of elements in this dimension. */
3009 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3010 stride = gfc_evaluate_now (stride, pblock);
3013 /* The stride is the number of elements in the array, so multiply by the
3014 size of an element to get the total size. */
3015 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3016 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3018 if (poffset != NULL)
3020 offset = gfc_evaluate_now (offset, pblock);
3024 size = gfc_evaluate_now (size, pblock);
3029 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3030 the work for an ALLOCATE statement. */
3034 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3044 int allocatable_array;
3048 /* Find the last reference in the chain. */
3049 while (ref && ref->next != NULL)
3051 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3055 if (ref == NULL || ref->type != REF_ARRAY)
3058 /* Figure out the size of the array. */
3059 switch (ref->u.ar.type)
3063 upper = ref->u.ar.start;
3067 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3069 lower = ref->u.ar.as->lower;
3070 upper = ref->u.ar.as->upper;
3074 lower = ref->u.ar.start;
3075 upper = ref->u.ar.end;
3083 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3084 lower, upper, &se->pre);
3086 /* Allocate memory to store the data. */
3087 tmp = gfc_conv_descriptor_data_addr (se->expr);
3088 pointer = gfc_evaluate_now (tmp, &se->pre);
3090 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3092 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3094 if (allocatable_array)
3095 allocate = gfor_fndecl_allocate_array;
3097 allocate = gfor_fndecl_allocate;
3099 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3101 if (allocatable_array)
3102 allocate = gfor_fndecl_allocate64_array;
3104 allocate = gfor_fndecl_allocate64;
3109 tmp = gfc_chainon_list (NULL_TREE, pointer);
3110 tmp = gfc_chainon_list (tmp, size);
3111 tmp = gfc_chainon_list (tmp, pstat);
3112 tmp = build_function_call_expr (allocate, tmp);
3113 gfc_add_expr_to_block (&se->pre, tmp);
3115 tmp = gfc_conv_descriptor_offset (se->expr);
3116 gfc_add_modify_expr (&se->pre, tmp, offset);
3122 /* Deallocate an array variable. Also used when an allocated variable goes
3127 gfc_array_deallocate (tree descriptor, tree pstat)
3133 gfc_start_block (&block);
3134 /* Get a pointer to the data. */
3135 tmp = gfc_conv_descriptor_data_addr (descriptor);
3136 var = gfc_evaluate_now (tmp, &block);
3138 /* Parameter is the address of the data component. */
3139 tmp = gfc_chainon_list (NULL_TREE, var);
3140 tmp = gfc_chainon_list (tmp, pstat);
3141 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3142 gfc_add_expr_to_block (&block, tmp);
3144 return gfc_finish_block (&block);
3148 /* Create an array constructor from an initialization expression.
3149 We assume the frontend already did any expansions and conversions. */
3152 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3159 unsigned HOST_WIDE_INT lo;
3161 VEC(constructor_elt,gc) *v = NULL;
3163 switch (expr->expr_type)
3166 case EXPR_STRUCTURE:
3167 /* A single scalar or derived type value. Create an array with all
3168 elements equal to that value. */
3169 gfc_init_se (&se, NULL);
3171 if (expr->expr_type == EXPR_CONSTANT)
3172 gfc_conv_constant (&se, expr);
3174 gfc_conv_structure (&se, expr, 1);
3176 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3177 gcc_assert (tmp && INTEGER_CST_P (tmp));
3178 hi = TREE_INT_CST_HIGH (tmp);
3179 lo = TREE_INT_CST_LOW (tmp);
3183 /* This will probably eat buckets of memory for large arrays. */
3184 while (hi != 0 || lo != 0)
3186 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3194 /* Create a vector of all the elements. */
3195 for (c = expr->value.constructor; c; c = c->next)
3199 /* Problems occur when we get something like
3200 integer :: a(lots) = (/(i, i=1,lots)/) */
3201 /* TODO: Unexpanded array initializers. */
3203 ("Possible frontend bug: array constructor not expanded");
3205 if (mpz_cmp_si (c->n.offset, 0) != 0)
3206 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3210 if (mpz_cmp_si (c->repeat, 0) != 0)
3214 mpz_set (maxval, c->repeat);
3215 mpz_add (maxval, c->n.offset, maxval);
3216 mpz_sub_ui (maxval, maxval, 1);
3217 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3218 if (mpz_cmp_si (c->n.offset, 0) != 0)
3220 mpz_add_ui (maxval, c->n.offset, 1);
3221 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3224 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3226 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3232 gfc_init_se (&se, NULL);
3233 switch (c->expr->expr_type)
3236 gfc_conv_constant (&se, c->expr);
3237 if (range == NULL_TREE)
3238 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3241 if (index != NULL_TREE)
3242 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3243 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3247 case EXPR_STRUCTURE:
3248 gfc_conv_structure (&se, c->expr, 1);
3249 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3262 /* Create a constructor from the list of elements. */
3263 tmp = build_constructor (type, v);
3264 TREE_CONSTANT (tmp) = 1;
3265 TREE_INVARIANT (tmp) = 1;
3270 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3271 returns the size (in elements) of the array. */
3274 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3275 stmtblock_t * pblock)
3290 size = gfc_index_one_node;
3291 offset = gfc_index_zero_node;
3292 for (dim = 0; dim < as->rank; dim++)
3294 /* Evaluate non-constant array bound expressions. */
3295 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3296 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3298 gfc_init_se (&se, NULL);
3299 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3300 gfc_add_block_to_block (pblock, &se.pre);
3301 gfc_add_modify_expr (pblock, lbound, se.expr);
3303 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3304 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3306 gfc_init_se (&se, NULL);
3307 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3308 gfc_add_block_to_block (pblock, &se.pre);
3309 gfc_add_modify_expr (pblock, ubound, se.expr);
3311 /* The offset of this dimension. offset = offset - lbound * stride. */
3312 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3313 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3315 /* The size of this dimension, and the stride of the next. */
3316 if (dim + 1 < as->rank)
3317 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3319 stride = GFC_TYPE_ARRAY_SIZE (type);
3321 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3323 /* Calculate stride = size * (ubound + 1 - lbound). */
3324 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3325 gfc_index_one_node, lbound);
3326 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3327 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3329 gfc_add_modify_expr (pblock, stride, tmp);
3331 stride = gfc_evaluate_now (tmp, pblock);
3337 gfc_trans_vla_type_sizes (sym, pblock);
3344 /* Generate code to initialize/allocate an array variable. */
3347 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3357 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3359 /* Do nothing for USEd variables. */
3360 if (sym->attr.use_assoc)
3363 type = TREE_TYPE (decl);
3364 gcc_assert (GFC_ARRAY_TYPE_P (type));
3365 onstack = TREE_CODE (type) != POINTER_TYPE;
3367 gfc_start_block (&block);
3369 /* Evaluate character string length. */
3370 if (sym->ts.type == BT_CHARACTER
3371 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3373 gfc_trans_init_string_length (sym->ts.cl, &block);
3375 gfc_trans_vla_type_sizes (sym, &block);
3377 /* Emit a DECL_EXPR for this variable, which will cause the
3378 gimplifier to allocate storage, and all that good stuff. */
3379 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3380 gfc_add_expr_to_block (&block, tmp);
3385 gfc_add_expr_to_block (&block, fnbody);
3386 return gfc_finish_block (&block);
3389 type = TREE_TYPE (type);
3391 gcc_assert (!sym->attr.use_assoc);
3392 gcc_assert (!TREE_STATIC (decl));
3393 gcc_assert (!sym->module);
3395 if (sym->ts.type == BT_CHARACTER
3396 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3397 gfc_trans_init_string_length (sym->ts.cl, &block);
3399 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3401 /* Don't actually allocate space for Cray Pointees. */
3402 if (sym->attr.cray_pointee)
3404 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3405 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3406 gfc_add_expr_to_block (&block, fnbody);
3407 return gfc_finish_block (&block);
3410 /* The size is the number of elements in the array, so multiply by the
3411 size of an element to get the total size. */
3412 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3413 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3415 /* Allocate memory to hold the data. */
3416 tmp = gfc_chainon_list (NULL_TREE, size);
3418 if (gfc_index_integer_kind == 4)
3419 fndecl = gfor_fndecl_internal_malloc;
3420 else if (gfc_index_integer_kind == 8)
3421 fndecl = gfor_fndecl_internal_malloc64;
3424 tmp = build_function_call_expr (fndecl, tmp);
3425 tmp = fold (convert (TREE_TYPE (decl), tmp));
3426 gfc_add_modify_expr (&block, decl, tmp);
3428 /* Set offset of the array. */
3429 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3430 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3433 /* Automatic arrays should not have initializers. */
3434 gcc_assert (!sym->value);
3436 gfc_add_expr_to_block (&block, fnbody);
3438 /* Free the temporary. */
3439 tmp = convert (pvoid_type_node, decl);
3440 tmp = gfc_chainon_list (NULL_TREE, tmp);
3441 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3442 gfc_add_expr_to_block (&block, tmp);
3444 return gfc_finish_block (&block);
3448 /* Generate entry and exit code for g77 calling convention arrays. */
3451 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3460 gfc_get_backend_locus (&loc);
3461 gfc_set_backend_locus (&sym->declared_at);
3463 /* Descriptor type. */
3464 parm = sym->backend_decl;
3465 type = TREE_TYPE (parm);
3466 gcc_assert (GFC_ARRAY_TYPE_P (type));
3468 gfc_start_block (&block);
3470 if (sym->ts.type == BT_CHARACTER
3471 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3472 gfc_trans_init_string_length (sym->ts.cl, &block);
3474 /* Evaluate the bounds of the array. */
3475 gfc_trans_array_bounds (type, sym, &offset, &block);
3477 /* Set the offset. */
3478 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3479 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3481 /* Set the pointer itself if we aren't using the parameter directly. */
3482 if (TREE_CODE (parm) != PARM_DECL)
3484 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3485 gfc_add_modify_expr (&block, parm, tmp);
3487 tmp = gfc_finish_block (&block);
3489 gfc_set_backend_locus (&loc);
3491 gfc_start_block (&block);
3492 /* Add the initialization code to the start of the function. */
3493 gfc_add_expr_to_block (&block, tmp);
3494 gfc_add_expr_to_block (&block, body);
3496 return gfc_finish_block (&block);
3500 /* Modify the descriptor of an array parameter so that it has the
3501 correct lower bound. Also move the upper bound accordingly.
3502 If the array is not packed, it will be copied into a temporary.
3503 For each dimension we set the new lower and upper bounds. Then we copy the
3504 stride and calculate the offset for this dimension. We also work out
3505 what the stride of a packed array would be, and see it the two match.
3506 If the array need repacking, we set the stride to the values we just
3507 calculated, recalculate the offset and copy the array data.
3508 Code is also added to copy the data back at the end of the function.
3512 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3519 stmtblock_t cleanup;
3537 /* Do nothing for pointer and allocatable arrays. */
3538 if (sym->attr.pointer || sym->attr.allocatable)
3541 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3542 return gfc_trans_g77_array (sym, body);
3544 gfc_get_backend_locus (&loc);
3545 gfc_set_backend_locus (&sym->declared_at);
3547 /* Descriptor type. */
3548 type = TREE_TYPE (tmpdesc);
3549 gcc_assert (GFC_ARRAY_TYPE_P (type));
3550 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3551 dumdesc = build_fold_indirect_ref (dumdesc);
3552 gfc_start_block (&block);
3554 if (sym->ts.type == BT_CHARACTER
3555 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3556 gfc_trans_init_string_length (sym->ts.cl, &block);
3558 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3560 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3561 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3563 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3565 /* For non-constant shape arrays we only check if the first dimension
3566 is contiguous. Repacking higher dimensions wouldn't gain us
3567 anything as we still don't know the array stride. */
3568 partial = gfc_create_var (boolean_type_node, "partial");
3569 TREE_USED (partial) = 1;
3570 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3571 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
3572 gfc_add_modify_expr (&block, partial, tmp);
3576 partial = NULL_TREE;
3579 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3580 here, however I think it does the right thing. */
3583 /* Set the first stride. */
3584 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3585 stride = gfc_evaluate_now (stride, &block);
3587 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
3588 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3589 gfc_index_one_node, stride);
3590 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3591 gfc_add_modify_expr (&block, stride, tmp);
3593 /* Allow the user to disable array repacking. */
3594 stmt_unpacked = NULL_TREE;
3598 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3599 /* A library call to repack the array if necessary. */
3600 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3601 tmp = gfc_chainon_list (NULL_TREE, tmp);
3602 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3604 stride = gfc_index_one_node;
3607 /* This is for the case where the array data is used directly without
3608 calling the repack function. */
3609 if (no_repack || partial != NULL_TREE)
3610 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3612 stmt_packed = NULL_TREE;
3614 /* Assign the data pointer. */
3615 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3617 /* Don't repack unknown shape arrays when the first stride is 1. */
3618 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3619 stmt_packed, stmt_unpacked);
3622 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3623 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3625 offset = gfc_index_zero_node;
3626 size = gfc_index_one_node;
3628 /* Evaluate the bounds of the array. */
3629 for (n = 0; n < sym->as->rank; n++)
3631 if (checkparm || !sym->as->upper[n])
3633 /* Get the bounds of the actual parameter. */
3634 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3635 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3639 dubound = NULL_TREE;
3640 dlbound = NULL_TREE;
3643 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3644 if (!INTEGER_CST_P (lbound))
3646 gfc_init_se (&se, NULL);
3647 gfc_conv_expr_type (&se, sym->as->lower[n],
3648 gfc_array_index_type);
3649 gfc_add_block_to_block (&block, &se.pre);
3650 gfc_add_modify_expr (&block, lbound, se.expr);
3653 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3654 /* Set the desired upper bound. */
3655 if (sym->as->upper[n])
3657 /* We know what we want the upper bound to be. */
3658 if (!INTEGER_CST_P (ubound))
3660 gfc_init_se (&se, NULL);
3661 gfc_conv_expr_type (&se, sym->as->upper[n],
3662 gfc_array_index_type);
3663 gfc_add_block_to_block (&block, &se.pre);
3664 gfc_add_modify_expr (&block, ubound, se.expr);
3667 /* Check the sizes match. */
3670 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3672 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3674 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3676 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3677 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3682 /* For assumed shape arrays move the upper bound by the same amount
3683 as the lower bound. */
3684 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3685 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3686 gfc_add_modify_expr (&block, ubound, tmp);
3688 /* The offset of this dimension. offset = offset - lbound * stride. */
3689 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3690 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3692 /* The size of this dimension, and the stride of the next. */
3693 if (n + 1 < sym->as->rank)
3695 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3697 if (no_repack || partial != NULL_TREE)
3700 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3703 /* Figure out the stride if not a known constant. */
3704 if (!INTEGER_CST_P (stride))
3707 stmt_packed = NULL_TREE;
3710 /* Calculate stride = size * (ubound + 1 - lbound). */
3711 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3712 gfc_index_one_node, lbound);
3713 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3715 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3720 /* Assign the stride. */
3721 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3722 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3723 stmt_unpacked, stmt_packed);
3725 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3726 gfc_add_modify_expr (&block, stride, tmp);
3731 stride = GFC_TYPE_ARRAY_SIZE (type);
3733 if (stride && !INTEGER_CST_P (stride))
3735 /* Calculate size = stride * (ubound + 1 - lbound). */
3736 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3737 gfc_index_one_node, lbound);
3738 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3740 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3741 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
3742 gfc_add_modify_expr (&block, stride, tmp);
3747 /* Set the offset. */
3748 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3749 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3751 gfc_trans_vla_type_sizes (sym, &block);
3753 stmt = gfc_finish_block (&block);
3755 gfc_start_block (&block);
3757 /* Only do the entry/initialization code if the arg is present. */
3758 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3759 optional_arg = (sym->attr.optional
3760 || (sym->ns->proc_name->attr.entry_master
3761 && sym->attr.dummy));
3764 tmp = gfc_conv_expr_present (sym);
3765 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3767 gfc_add_expr_to_block (&block, stmt);
3769 /* Add the main function body. */
3770 gfc_add_expr_to_block (&block, body);
3775 gfc_start_block (&cleanup);
3777 if (sym->attr.intent != INTENT_IN)
3779 /* Copy the data back. */
3780 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3781 tmp = gfc_chainon_list (tmp, tmpdesc);
3782 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3783 gfc_add_expr_to_block (&cleanup, tmp);
3786 /* Free the temporary. */
3787 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3788 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3789 gfc_add_expr_to_block (&cleanup, tmp);
3791 stmt = gfc_finish_block (&cleanup);
3793 /* Only do the cleanup if the array was repacked. */
3794 tmp = build_fold_indirect_ref (dumdesc);
3795 tmp = gfc_conv_descriptor_data_get (tmp);
3796 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3797 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3801 tmp = gfc_conv_expr_present (sym);
3802 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3804 gfc_add_expr_to_block (&block, stmt);
3806 /* We don't need to free any memory allocated by internal_pack as it will
3807 be freed at the end of the function by pop_context. */
3808 return gfc_finish_block (&block);
3812 /* Convert an array for passing as an actual argument. Expressions and
3813 vector subscripts are evaluated and stored in a temporary, which is then
3814 passed. For whole arrays the descriptor is passed. For array sections
3815 a modified copy of the descriptor is passed, but using the original data.
3817 This function is also used for array pointer assignments, and there
3820 - want_pointer && !se->direct_byref
3821 EXPR is an actual argument. On exit, se->expr contains a
3822 pointer to the array descriptor.
3824 - !want_pointer && !se->direct_byref
3825 EXPR is an actual argument to an intrinsic function or the
3826 left-hand side of a pointer assignment. On exit, se->expr
3827 contains the descriptor for EXPR.
3829 - !want_pointer && se->direct_byref
3830 EXPR is the right-hand side of a pointer assignment and
3831 se->expr is the descriptor for the previously-evaluated
3832 left-hand side. The function creates an assignment from
3833 EXPR to se->expr. */
3836 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3851 gcc_assert (ss != gfc_ss_terminator);
3853 /* TODO: Pass constant array constructors without a temporary. */
3854 /* Special case things we know we can pass easily. */
3855 switch (expr->expr_type)
3858 /* If we have a linear array section, we can pass it directly.
3859 Otherwise we need to copy it into a temporary. */
3861 /* Find the SS for the array section. */
3863 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3864 secss = secss->next;
3866 gcc_assert (secss != gfc_ss_terminator);
3867 info = &secss->data.info;
3869 /* Get the descriptor for the array. */
3870 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3871 desc = info->descriptor;
3873 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3876 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3878 /* Create a new descriptor if the array doesn't have one. */
3881 else if (info->ref->u.ar.type == AR_FULL)
3883 else if (se->direct_byref)
3888 gcc_assert (ref->u.ar.type == AR_SECTION);
3891 for (n = 0; n < ref->u.ar.dimen; n++)
3893 /* Detect passing the full array as a section. This could do
3894 even more checking, but it doesn't seem worth it. */
3895 if (ref->u.ar.start[n]
3897 || (ref->u.ar.stride[n]
3898 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3908 if (se->direct_byref)
3910 /* Copy the descriptor for pointer assignments. */
3911 gfc_add_modify_expr (&se->pre, se->expr, desc);
3913 else if (se->want_pointer)
3915 /* We pass full arrays directly. This means that pointers and
3916 allocatable arrays should also work. */
3917 se->expr = build_fold_addr_expr (desc);
3924 if (expr->ts.type == BT_CHARACTER)
3925 se->string_length = gfc_get_expr_charlen (expr);
3932 /* A transformational function return value will be a temporary
3933 array descriptor. We still need to go through the scalarizer
3934 to create the descriptor. Elemental functions ar handled as
3935 arbitrary expressions, i.e. copy to a temporary. */
3937 /* Look for the SS for this function. */
3938 while (secss != gfc_ss_terminator
3939 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3940 secss = secss->next;
3942 if (se->direct_byref)
3944 gcc_assert (secss != gfc_ss_terminator);
3946 /* For pointer assignments pass the descriptor directly. */
3948 se->expr = build_fold_addr_expr (se->expr);
3949 gfc_conv_expr (se, expr);
3953 if (secss == gfc_ss_terminator)
3955 /* Elemental function. */
3961 /* Transformational function. */
3962 info = &secss->data.info;
3968 /* Something complicated. Copy it into a temporary. */
3976 gfc_init_loopinfo (&loop);
3978 /* Associate the SS with the loop. */
3979 gfc_add_ss_to_loop (&loop, ss);
3981 /* Tell the scalarizer not to bother creating loop variables, etc. */
3983 loop.array_parameter = 1;
3985 /* The right-hand side of a pointer assignment mustn't use a temporary. */
3986 gcc_assert (!se->direct_byref);
3988 /* Setup the scalarizing loops and bounds. */
3989 gfc_conv_ss_startstride (&loop);
3993 /* Tell the scalarizer to make a temporary. */
3994 loop.temp_ss = gfc_get_ss ();
3995 loop.temp_ss->type = GFC_SS_TEMP;
3996 loop.temp_ss->next = gfc_ss_terminator;
3997 if (expr->ts.type == BT_CHARACTER)
4000 && expr->ts.cl->length
4001 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4003 expr->ts.cl->backend_decl
4004 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4005 expr->ts.cl->length->ts.kind);
4006 loop.temp_ss->data.temp.type
4007 = gfc_typenode_for_spec (&expr->ts);
4008 loop.temp_ss->string_length
4009 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4013 loop.temp_ss->data.temp.type
4014 = gfc_typenode_for_spec (&expr->ts);
4015 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4017 se->string_length = loop.temp_ss->string_length;
4021 loop.temp_ss->data.temp.type
4022 = gfc_typenode_for_spec (&expr->ts);
4023 loop.temp_ss->string_length = NULL;
4025 loop.temp_ss->data.temp.dimen = loop.dimen;
4026 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4029 gfc_conv_loop_setup (&loop);
4033 /* Copy into a temporary and pass that. We don't need to copy the data
4034 back because expressions and vector subscripts must be INTENT_IN. */
4035 /* TODO: Optimize passing function return values. */
4039 /* Start the copying loops. */
4040 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4041 gfc_mark_ss_chain_used (ss, 1);
4042 gfc_start_scalarized_body (&loop, &block);
4044 /* Copy each data element. */
4045 gfc_init_se (&lse, NULL);
4046 gfc_copy_loopinfo_to_se (&lse, &loop);
4047 gfc_init_se (&rse, NULL);
4048 gfc_copy_loopinfo_to_se (&rse, &loop);
4050 lse.ss = loop.temp_ss;
4053 gfc_conv_scalarized_array_ref (&lse, NULL);
4054 if (expr->ts.type == BT_CHARACTER)
4056 gfc_conv_expr (&rse, expr);
4057 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4058 rse.expr = build_fold_indirect_ref (rse.expr);
4061 gfc_conv_expr_val (&rse, expr);
4063 gfc_add_block_to_block (&block, &rse.pre);
4064 gfc_add_block_to_block (&block, &lse.pre);
4066 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4068 /* Finish the copying loops. */
4069 gfc_trans_scalarizing_loops (&loop, &block);
4071 /* Set the first stride component to zero to indicate a temporary. */
4072 desc = loop.temp_ss->data.info.descriptor;
4073 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
4074 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4076 gcc_assert (is_gimple_lvalue (desc));
4078 else if (expr->expr_type == EXPR_FUNCTION)
4080 desc = info->descriptor;
4081 se->string_length = ss->string_length;
4085 /* We pass sections without copying to a temporary. Make a new
4086 descriptor and point it at the section we want. The loop variable
4087 limits will be the limits of the section.
4088 A function may decide to repack the array to speed up access, but
4089 we're not bothered about that here. */
4098 /* Set the string_length for a character array. */
4099 if (expr->ts.type == BT_CHARACTER)
4100 se->string_length = gfc_get_expr_charlen (expr);
4102 desc = info->descriptor;
4103 gcc_assert (secss && secss != gfc_ss_terminator);
4104 if (se->direct_byref)
4106 /* For pointer assignments we fill in the destination. */
4108 parmtype = TREE_TYPE (parm);
4112 /* Otherwise make a new one. */
4113 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4114 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4115 loop.from, loop.to, 0);
4116 parm = gfc_create_var (parmtype, "parm");
4119 offset = gfc_index_zero_node;
4122 /* The following can be somewhat confusing. We have two
4123 descriptors, a new one and the original array.
4124 {parm, parmtype, dim} refer to the new one.
4125 {desc, type, n, secss, loop} refer to the original, which maybe
4126 a descriptorless array.
4127 The bounds of the scalarization are the bounds of the section.
4128 We don't have to worry about numeric overflows when calculating
4129 the offsets because all elements are within the array data. */
4131 /* Set the dtype. */
4132 tmp = gfc_conv_descriptor_dtype (parm);
4133 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4135 if (se->direct_byref)
4136 base = gfc_index_zero_node;
4140 for (n = 0; n < info->ref->u.ar.dimen; n++)
4142 stride = gfc_conv_array_stride (desc, n);
4144 /* Work out the offset. */
4145 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4147 gcc_assert (info->subscript[n]
4148 && info->subscript[n]->type == GFC_SS_SCALAR);
4149 start = info->subscript[n]->data.scalar.expr;
4153 /* Check we haven't somehow got out of sync. */
4154 gcc_assert (info->dim[dim] == n);
4156 /* Evaluate and remember the start of the section. */
4157 start = info->start[dim];
4158 stride = gfc_evaluate_now (stride, &loop.pre);
4161 tmp = gfc_conv_array_lbound (desc, n);
4162 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4164 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4165 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4167 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4169 /* For elemental dimensions, we only need the offset. */
4173 /* Vector subscripts need copying and are handled elsewhere. */
4174 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4176 /* Set the new lower bound. */
4177 from = loop.from[dim];
4180 /* If we have an array section or are assigning to a pointer,
4181 make sure that the lower bound is 1. References to the full
4182 array should otherwise keep the original bounds. */
4183 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4184 && !integer_onep (from))
4186 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4187 gfc_index_one_node, from);
4188 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4189 from = gfc_index_one_node;
4191 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4192 gfc_add_modify_expr (&loop.pre, tmp, from);
4194 /* Set the new upper bound. */
4195 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4196 gfc_add_modify_expr (&loop.pre, tmp, to);
4198 /* Multiply the stride by the section stride to get the
4200 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4201 stride, info->stride[dim]);
4203 if (se->direct_byref)
4204 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4207 /* Store the new stride. */
4208 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4209 gfc_add_modify_expr (&loop.pre, tmp, stride);
4214 if (se->data_not_needed)
4215 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4218 /* Point the data pointer at the first element in the section. */
4219 tmp = gfc_conv_array_data (desc);
4220 tmp = build_fold_indirect_ref (tmp);
4221 tmp = gfc_build_array_ref (tmp, offset);
4222 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4223 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4226 if (se->direct_byref && !se->data_not_needed)
4228 /* Set the offset. */
4229 tmp = gfc_conv_descriptor_offset (parm);
4230 gfc_add_modify_expr (&loop.pre, tmp, base);
4234 /* Only the callee knows what the correct offset it, so just set
4236 tmp = gfc_conv_descriptor_offset (parm);
4237 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4242 if (!se->direct_byref)
4244 /* Get a pointer to the new descriptor. */
4245 if (se->want_pointer)
4246 se->expr = build_fold_addr_expr (desc);
4251 gfc_add_block_to_block (&se->pre, &loop.pre);
4252 gfc_add_block_to_block (&se->post, &loop.post);
4254 /* Cleanup the scalarizer. */
4255 gfc_cleanup_loop (&loop);
4259 /* Convert an array for passing as an actual parameter. */
4260 /* TODO: Optimize passing g77 arrays. */
4263 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4272 /* Passing address of the array if it is not pointer or assumed-shape. */
4273 if (expr->expr_type == EXPR_VARIABLE
4274 && expr->ref->u.ar.type == AR_FULL && g77)
4276 sym = expr->symtree->n.sym;
4277 tmp = gfc_get_symbol_decl (sym);
4279 if (sym->ts.type == BT_CHARACTER)
4280 se->string_length = sym->ts.cl->backend_decl;
4281 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4282 && !sym->attr.allocatable)
4284 /* Some variables are declared directly, others are declared as
4285 pointers and allocated on the heap. */
4286 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4289 se->expr = build_fold_addr_expr (tmp);
4292 if (sym->attr.allocatable)
4294 se->expr = gfc_conv_array_data (tmp);
4299 se->want_pointer = 1;
4300 gfc_conv_expr_descriptor (se, expr, ss);
4305 /* Repack the array. */
4306 tmp = gfc_chainon_list (NULL_TREE, desc);
4307 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4308 ptr = gfc_evaluate_now (ptr, &se->pre);
4311 gfc_start_block (&block);
4313 /* Copy the data back. */
4314 tmp = gfc_chainon_list (NULL_TREE, desc);
4315 tmp = gfc_chainon_list (tmp, ptr);
4316 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4317 gfc_add_expr_to_block (&block, tmp);
4319 /* Free the temporary. */
4320 tmp = convert (pvoid_type_node, ptr);
4321 tmp = gfc_chainon_list (NULL_TREE, tmp);
4322 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4323 gfc_add_expr_to_block (&block, tmp);
4325 stmt = gfc_finish_block (&block);
4327 gfc_init_block (&block);
4328 /* Only if it was repacked. This code needs to be executed before the
4329 loop cleanup code. */
4330 tmp = build_fold_indirect_ref (desc);
4331 tmp = gfc_conv_array_data (tmp);
4332 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4333 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4335 gfc_add_expr_to_block (&block, tmp);
4336 gfc_add_block_to_block (&block, &se->post);
4338 gfc_init_block (&se->post);
4339 gfc_add_block_to_block (&se->post, &block);
4344 /* Generate code to deallocate an array, if it is allocated. */
4347 gfc_trans_dealloc_allocated (tree descriptor)
4353 gfc_start_block (&block);
4354 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4356 tmp = gfc_conv_descriptor_data_get (descriptor);
4357 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4358 build_int_cst (TREE_TYPE (tmp), 0));
4359 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4360 gfc_add_expr_to_block (&block, tmp);
4362 tmp = gfc_finish_block (&block);
4368 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4371 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4376 stmtblock_t fnblock;
4379 /* Make sure the frontend gets these right. */
4380 if (!(sym->attr.pointer || sym->attr.allocatable))
4382 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4384 gfc_init_block (&fnblock);
4386 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4387 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4389 if (sym->ts.type == BT_CHARACTER
4390 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4392 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4393 gfc_trans_vla_type_sizes (sym, &fnblock);
4396 /* Dummy and use associated variables don't need anything special. */
4397 if (sym->attr.dummy || sym->attr.use_assoc)
4399 gfc_add_expr_to_block (&fnblock, body);
4401 return gfc_finish_block (&fnblock);
4404 gfc_get_backend_locus (&loc);
4405 gfc_set_backend_locus (&sym->declared_at);
4406 descriptor = sym->backend_decl;
4408 if (TREE_STATIC (descriptor))
4410 /* SAVEd variables are not freed on exit. */
4411 gfc_trans_static_array_pointer (sym);
4415 /* Get the descriptor type. */
4416 type = TREE_TYPE (sym->backend_decl);
4417 if (!GFC_DESCRIPTOR_TYPE_P (type))
4419 /* If the backend_decl is not a descriptor, we must have a pointer
4421 descriptor = build_fold_indirect_ref (sym->backend_decl);
4422 type = TREE_TYPE (descriptor);
4423 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4426 /* NULLIFY the data pointer. */
4427 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4429 gfc_add_expr_to_block (&fnblock, body);
4431 gfc_set_backend_locus (&loc);
4432 /* Allocatable arrays need to be freed when they go out of scope. */
4433 if (sym->attr.allocatable)
4435 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4436 gfc_add_expr_to_block (&fnblock, tmp);
4439 return gfc_finish_block (&fnblock);
4442 /************ Expression Walking Functions ******************/
4444 /* Walk a variable reference.
4446 Possible extension - multiple component subscripts.
4447 x(:,:) = foo%a(:)%b(:)
4449 forall (i=..., j=...)
4450 x(i,j) = foo%a(j)%b(i)
4452 This adds a fair amout of complexity because you need to deal with more
4453 than one ref. Maybe handle in a similar manner to vector subscripts.
4454 Maybe not worth the effort. */
4458 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4466 for (ref = expr->ref; ref; ref = ref->next)
4467 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4470 for (; ref; ref = ref->next)
4472 if (ref->type == REF_SUBSTRING)
4474 newss = gfc_get_ss ();
4475 newss->type = GFC_SS_SCALAR;
4476 newss->expr = ref->u.ss.start;
4480 newss = gfc_get_ss ();
4481 newss->type = GFC_SS_SCALAR;
4482 newss->expr = ref->u.ss.end;
4487 /* We're only interested in array sections from now on. */
4488 if (ref->type != REF_ARRAY)
4495 for (n = 0; n < ar->dimen; n++)
4497 newss = gfc_get_ss ();
4498 newss->type = GFC_SS_SCALAR;
4499 newss->expr = ar->start[n];
4506 newss = gfc_get_ss ();
4507 newss->type = GFC_SS_SECTION;
4510 newss->data.info.dimen = ar->as->rank;
4511 newss->data.info.ref = ref;
4513 /* Make sure array is the same as array(:,:), this way
4514 we don't need to special case all the time. */
4515 ar->dimen = ar->as->rank;
4516 for (n = 0; n < ar->dimen; n++)
4518 newss->data.info.dim[n] = n;
4519 ar->dimen_type[n] = DIMEN_RANGE;
4521 gcc_assert (ar->start[n] == NULL);
4522 gcc_assert (ar->end[n] == NULL);
4523 gcc_assert (ar->stride[n] == NULL);
4529 newss = gfc_get_ss ();
4530 newss->type = GFC_SS_SECTION;
4533 newss->data.info.dimen = 0;
4534 newss->data.info.ref = ref;
4538 /* We add SS chains for all the subscripts in the section. */
4539 for (n = 0; n < ar->dimen; n++)
4543 switch (ar->dimen_type[n])
4546 /* Add SS for elemental (scalar) subscripts. */
4547 gcc_assert (ar->start[n]);
4548 indexss = gfc_get_ss ();
4549 indexss->type = GFC_SS_SCALAR;
4550 indexss->expr = ar->start[n];
4551 indexss->next = gfc_ss_terminator;
4552 indexss->loop_chain = gfc_ss_terminator;
4553 newss->data.info.subscript[n] = indexss;
4557 /* We don't add anything for sections, just remember this
4558 dimension for later. */
4559 newss->data.info.dim[newss->data.info.dimen] = n;
4560 newss->data.info.dimen++;
4564 /* Create a GFC_SS_VECTOR index in which we can store
4565 the vector's descriptor. */
4566 indexss = gfc_get_ss ();
4567 indexss->type = GFC_SS_VECTOR;
4568 indexss->expr = ar->start[n];
4569 indexss->next = gfc_ss_terminator;
4570 indexss->loop_chain = gfc_ss_terminator;
4571 newss->data.info.subscript[n] = indexss;
4572 newss->data.info.dim[newss->data.info.dimen] = n;
4573 newss->data.info.dimen++;
4577 /* We should know what sort of section it is by now. */
4581 /* We should have at least one non-elemental dimension. */
4582 gcc_assert (newss->data.info.dimen > 0);
4587 /* We should know what sort of section it is by now. */
4596 /* Walk an expression operator. If only one operand of a binary expression is
4597 scalar, we must also add the scalar term to the SS chain. */
4600 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4606 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4607 if (expr->value.op.op2 == NULL)
4610 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4612 /* All operands are scalar. Pass back and let the caller deal with it. */
4616 /* All operands require scalarization. */
4617 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4620 /* One of the operands needs scalarization, the other is scalar.
4621 Create a gfc_ss for the scalar expression. */
4622 newss = gfc_get_ss ();
4623 newss->type = GFC_SS_SCALAR;
4626 /* First operand is scalar. We build the chain in reverse order, so
4627 add the scarar SS after the second operand. */
4629 while (head && head->next != ss)
4631 /* Check we haven't somehow broken the chain. */
4635 newss->expr = expr->value.op.op1;
4637 else /* head2 == head */
4639 gcc_assert (head2 == head);
4640 /* Second operand is scalar. */
4641 newss->next = head2;
4643 newss->expr = expr->value.op.op2;
4650 /* Reverse a SS chain. */
4653 gfc_reverse_ss (gfc_ss * ss)
4658 gcc_assert (ss != NULL);
4660 head = gfc_ss_terminator;
4661 while (ss != gfc_ss_terminator)
4664 /* Check we didn't somehow break the chain. */
4665 gcc_assert (next != NULL);
4675 /* Walk the arguments of an elemental function. */
4678 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4686 head = gfc_ss_terminator;
4689 for (; arg; arg = arg->next)
4694 newss = gfc_walk_subexpr (head, arg->expr);
4697 /* Scalar argument. */
4698 newss = gfc_get_ss ();
4700 newss->expr = arg->expr;
4710 while (tail->next != gfc_ss_terminator)
4717 /* If all the arguments are scalar we don't need the argument SS. */
4718 gfc_free_ss_chain (head);
4723 /* Add it onto the existing chain. */
4729 /* Walk a function call. Scalar functions are passed back, and taken out of
4730 scalarization loops. For elemental functions we walk their arguments.
4731 The result of functions returning arrays is stored in a temporary outside
4732 the loop, so that the function is only called once. Hence we do not need
4733 to walk their arguments. */
4736 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4739 gfc_intrinsic_sym *isym;
4742 isym = expr->value.function.isym;
4744 /* Handle intrinsic functions separately. */
4746 return gfc_walk_intrinsic_function (ss, expr, isym);
4748 sym = expr->value.function.esym;
4750 sym = expr->symtree->n.sym;
4752 /* A function that returns arrays. */
4753 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4755 newss = gfc_get_ss ();
4756 newss->type = GFC_SS_FUNCTION;
4759 newss->data.info.dimen = expr->rank;
4763 /* Walk the parameters of an elemental function. For now we always pass
4765 if (sym->attr.elemental)
4766 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
4769 /* Scalar functions are OK as these are evaluated outside the scalarization
4770 loop. Pass back and let the caller deal with it. */
4775 /* An array temporary is constructed for array constructors. */
4778 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4783 newss = gfc_get_ss ();
4784 newss->type = GFC_SS_CONSTRUCTOR;
4787 newss->data.info.dimen = expr->rank;
4788 for (n = 0; n < expr->rank; n++)
4789 newss->data.info.dim[n] = n;
4795 /* Walk an expression. Add walked expressions to the head of the SS chain.
4796 A wholly scalar expression will not be added. */
4799 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4803 switch (expr->expr_type)
4806 head = gfc_walk_variable_expr (ss, expr);
4810 head = gfc_walk_op_expr (ss, expr);
4814 head = gfc_walk_function_expr (ss, expr);
4819 case EXPR_STRUCTURE:
4820 /* Pass back and let the caller deal with it. */
4824 head = gfc_walk_array_constructor (ss, expr);
4827 case EXPR_SUBSTRING:
4828 /* Pass back and let the caller deal with it. */
4832 internal_error ("bad expression type during walk (%d)",
4839 /* Entry point for expression walking.
4840 A return value equal to the passed chain means this is
4841 a scalar expression. It is up to the caller to take whatever action is
4842 necessary to translate these. */
4845 gfc_walk_expr (gfc_expr * expr)
4849 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4850 return gfc_reverse_ss (res);