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;
705 gcc_assert (dest_info->dimen == 2);
706 gcc_assert (src_info->dimen == 2);
708 /* Get a descriptor for EXPR. */
709 gfc_init_se (&src_se, NULL);
710 gfc_conv_expr_descriptor (&src_se, expr, src_ss);
711 gfc_add_block_to_block (&se->pre, &src_se.pre);
712 gfc_add_block_to_block (&se->post, &src_se.post);
715 /* Allocate a new descriptor for the return value. */
716 dest = gfc_create_var (TREE_TYPE (src), "atmp");
717 dest_info->descriptor = dest;
720 /* Copy across the dtype field. */
721 gfc_add_modify_expr (&se->pre,
722 gfc_conv_descriptor_dtype (dest),
723 gfc_conv_descriptor_dtype (src));
725 /* Copy the dimension information, renumbering dimension 1 to 0 and
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 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1039 gcc_assert (se.ss == gfc_ss_terminator);
1041 /* Increment the offset. */
1042 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
1043 gfc_add_modify_expr (&body, *poffset, tmp);
1045 /* Finish the loop. */
1046 gfc_trans_scalarizing_loops (&loop, &body);
1047 gfc_add_block_to_block (&loop.pre, &loop.post);
1048 tmp = gfc_finish_block (&loop.pre);
1049 gfc_add_expr_to_block (pblock, tmp);
1051 gfc_cleanup_loop (&loop);
1055 /* Assign the values to the elements of an array constructor. DYNAMIC
1056 is true if descriptor DESC only contains enough data for the static
1057 size calculated by gfc_get_array_constructor_size. When true, memory
1058 for the dynamic parts must be allocated using realloc. */
1061 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1062 tree desc, gfc_constructor * c,
1063 tree * poffset, tree * offsetvar,
1072 for (; c; c = c->next)
1074 /* If this is an iterator or an array, the offset must be a variable. */
1075 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1076 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1078 gfc_start_block (&body);
1080 if (c->expr->expr_type == EXPR_ARRAY)
1082 /* Array constructors can be nested. */
1083 gfc_trans_array_constructor_value (&body, type, desc,
1084 c->expr->value.constructor,
1085 poffset, offsetvar, dynamic);
1087 else if (c->expr->rank > 0)
1089 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1090 poffset, offsetvar, dynamic);
1094 /* This code really upsets the gimplifier so don't bother for now. */
1101 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1108 /* Scalar values. */
1109 gfc_init_se (&se, NULL);
1110 gfc_trans_array_ctor_element (&body, desc, *poffset,
1113 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1114 *poffset, gfc_index_one_node);
1118 /* Collect multiple scalar constants into a constructor. */
1126 /* Count the number of consecutive scalar constants. */
1127 while (p && !(p->iterator
1128 || p->expr->expr_type != EXPR_CONSTANT))
1130 gfc_init_se (&se, NULL);
1131 gfc_conv_constant (&se, p->expr);
1132 if (p->expr->ts.type == BT_CHARACTER
1133 && POINTER_TYPE_P (type))
1135 /* For constant character array constructors we build
1136 an array of pointers. */
1137 se.expr = gfc_build_addr_expr (pchar_type_node,
1141 list = tree_cons (NULL_TREE, se.expr, list);
1146 bound = build_int_cst (NULL_TREE, n - 1);
1147 /* Create an array type to hold them. */
1148 tmptype = build_range_type (gfc_array_index_type,
1149 gfc_index_zero_node, bound);
1150 tmptype = build_array_type (type, tmptype);
1152 init = build_constructor_from_list (tmptype, nreverse (list));
1153 TREE_CONSTANT (init) = 1;
1154 TREE_INVARIANT (init) = 1;
1155 TREE_STATIC (init) = 1;
1156 /* Create a static variable to hold the data. */
1157 tmp = gfc_create_var (tmptype, "data");
1158 TREE_STATIC (tmp) = 1;
1159 TREE_CONSTANT (tmp) = 1;
1160 TREE_INVARIANT (tmp) = 1;
1161 DECL_INITIAL (tmp) = init;
1164 /* Use BUILTIN_MEMCPY to assign the values. */
1165 tmp = gfc_conv_descriptor_data_get (desc);
1166 tmp = build_fold_indirect_ref (tmp);
1167 tmp = gfc_build_array_ref (tmp, *poffset);
1168 tmp = build_fold_addr_expr (tmp);
1169 init = build_fold_addr_expr (init);
1171 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1172 bound = build_int_cst (NULL_TREE, n * size);
1173 tmp = gfc_chainon_list (NULL_TREE, tmp);
1174 tmp = gfc_chainon_list (tmp, init);
1175 tmp = gfc_chainon_list (tmp, bound);
1176 tmp = build_function_call_expr (built_in_decls[BUILT_IN_MEMCPY],
1178 gfc_add_expr_to_block (&body, tmp);
1180 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1181 *poffset, build_int_cst (NULL_TREE, n));
1183 if (!INTEGER_CST_P (*poffset))
1185 gfc_add_modify_expr (&body, *offsetvar, *poffset);
1186 *poffset = *offsetvar;
1190 /* The frontend should already have done any expansions possible
1194 /* Pass the code as is. */
1195 tmp = gfc_finish_block (&body);
1196 gfc_add_expr_to_block (pblock, tmp);
1200 /* Build the implied do-loop. */
1209 loopbody = gfc_finish_block (&body);
1211 gfc_init_se (&se, NULL);
1212 gfc_conv_expr (&se, c->iterator->var);
1213 gfc_add_block_to_block (pblock, &se.pre);
1216 /* Initialize the loop. */
1217 gfc_init_se (&se, NULL);
1218 gfc_conv_expr_val (&se, c->iterator->start);
1219 gfc_add_block_to_block (pblock, &se.pre);
1220 gfc_add_modify_expr (pblock, loopvar, se.expr);
1222 gfc_init_se (&se, NULL);
1223 gfc_conv_expr_val (&se, c->iterator->end);
1224 gfc_add_block_to_block (pblock, &se.pre);
1225 end = gfc_evaluate_now (se.expr, pblock);
1227 gfc_init_se (&se, NULL);
1228 gfc_conv_expr_val (&se, c->iterator->step);
1229 gfc_add_block_to_block (pblock, &se.pre);
1230 step = gfc_evaluate_now (se.expr, pblock);
1232 /* If this array expands dynamically, and the number of iterations
1233 is not constant, we won't have allocated space for the static
1234 part of C->EXPR's size. Do that now. */
1235 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1237 /* Get the number of iterations. */
1238 tmp = gfc_get_iteration_count (loopvar, end, step);
1240 /* Get the static part of C->EXPR's size. */
1241 gfc_get_array_constructor_element_size (&size, c->expr);
1242 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1244 /* Grow the array by TMP * TMP2 elements. */
1245 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1246 gfc_grow_array (pblock, desc, tmp);
1249 /* Generate the loop body. */
1250 exit_label = gfc_build_label_decl (NULL_TREE);
1251 gfc_start_block (&body);
1253 /* Generate the exit condition. Depending on the sign of
1254 the step variable we have to generate the correct
1256 tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1257 build_int_cst (TREE_TYPE (step), 0));
1258 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1259 build2 (GT_EXPR, boolean_type_node,
1261 build2 (LT_EXPR, boolean_type_node,
1263 tmp = build1_v (GOTO_EXPR, exit_label);
1264 TREE_USED (exit_label) = 1;
1265 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1266 gfc_add_expr_to_block (&body, tmp);
1268 /* The main loop body. */
1269 gfc_add_expr_to_block (&body, loopbody);
1271 /* Increase loop variable by step. */
1272 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1273 gfc_add_modify_expr (&body, loopvar, tmp);
1275 /* Finish the loop. */
1276 tmp = gfc_finish_block (&body);
1277 tmp = build1_v (LOOP_EXPR, tmp);
1278 gfc_add_expr_to_block (pblock, tmp);
1280 /* Add the exit label. */
1281 tmp = build1_v (LABEL_EXPR, exit_label);
1282 gfc_add_expr_to_block (pblock, tmp);
1289 /* Figure out the string length of a variable reference expression.
1290 Used by get_array_ctor_strlen. */
1293 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1298 /* Don't bother if we already know the length is a constant. */
1299 if (*len && INTEGER_CST_P (*len))
1302 ts = &expr->symtree->n.sym->ts;
1303 for (ref = expr->ref; ref; ref = ref->next)
1308 /* Array references don't change the string length. */
1312 /* Use the length of the component. */
1313 ts = &ref->u.c.component->ts;
1317 /* TODO: Substrings are tricky because we can't evaluate the
1318 expression more than once. For now we just give up, and hope
1319 we can figure it out elsewhere. */
1324 *len = ts->cl->backend_decl;
1328 /* Figure out the string length of a character array constructor.
1329 Returns TRUE if all elements are character constants. */
1332 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1337 for (; c; c = c->next)
1339 switch (c->expr->expr_type)
1342 if (!(*len && INTEGER_CST_P (*len)))
1343 *len = build_int_cstu (gfc_charlen_type_node,
1344 c->expr->value.character.length);
1348 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1354 get_array_ctor_var_strlen (c->expr, len);
1359 /* TODO: For now we just ignore anything we don't know how to
1360 handle, and hope we can figure it out a different way. */
1369 /* Array constructors are handled by constructing a temporary, then using that
1370 within the scalarization loop. This is not optimal, but seems by far the
1374 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1384 ss->data.info.dimen = loop->dimen;
1386 c = ss->expr->value.constructor;
1387 if (ss->expr->ts.type == BT_CHARACTER)
1389 const_string = get_array_ctor_strlen (c, &ss->string_length);
1390 if (!ss->string_length)
1391 gfc_todo_error ("complex character array constructors");
1393 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1395 type = build_pointer_type (type);
1399 const_string = TRUE;
1400 type = gfc_typenode_for_spec (&ss->expr->ts);
1403 /* See if the constructor determines the loop bounds. */
1405 if (loop->to[0] == NULL_TREE)
1409 /* We should have a 1-dimensional, zero-based loop. */
1410 gcc_assert (loop->dimen == 1);
1411 gcc_assert (integer_zerop (loop->from[0]));
1413 /* Split the constructor size into a static part and a dynamic part.
1414 Allocate the static size up-front and record whether the dynamic
1415 size might be nonzero. */
1417 dynamic = gfc_get_array_constructor_size (&size, c);
1418 mpz_sub_ui (size, size, 1);
1419 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1423 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1424 type, dynamic, true, false);
1426 desc = ss->data.info.descriptor;
1427 offset = gfc_index_zero_node;
1428 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1429 TREE_USED (offsetvar) = 0;
1430 gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1431 &offset, &offsetvar, dynamic);
1433 /* If the array grows dynamically, the upper bound of the loop variable
1434 is determined by the array's final upper bound. */
1436 loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1438 if (TREE_USED (offsetvar))
1439 pushdecl (offsetvar);
1441 gcc_assert (INTEGER_CST_P (offset));
1443 /* Disable bound checking for now because it's probably broken. */
1444 if (flag_bounds_check)
1452 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1453 called after evaluating all of INFO's vector dimensions. Go through
1454 each such vector dimension and see if we can now fill in any missing
1458 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1467 for (n = 0; n < loop->dimen; n++)
1470 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1471 && loop->to[n] == NULL)
1473 /* Loop variable N indexes vector dimension DIM, and we don't
1474 yet know the upper bound of loop variable N. Set it to the
1475 difference between the vector's upper and lower bounds. */
1476 gcc_assert (loop->from[n] == gfc_index_zero_node);
1477 gcc_assert (info->subscript[dim]
1478 && info->subscript[dim]->type == GFC_SS_VECTOR);
1480 gfc_init_se (&se, NULL);
1481 desc = info->subscript[dim]->data.info.descriptor;
1482 zero = gfc_rank_cst[0];
1483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1484 gfc_conv_descriptor_ubound (desc, zero),
1485 gfc_conv_descriptor_lbound (desc, zero));
1486 tmp = gfc_evaluate_now (tmp, &loop->pre);
1493 /* Add the pre and post chains for all the scalar expressions in a SS chain
1494 to loop. This is called after the loop parameters have been calculated,
1495 but before the actual scalarizing loops. */
1498 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1503 /* TODO: This can generate bad code if there are ordering dependencies.
1504 eg. a callee allocated function and an unknown size constructor. */
1505 gcc_assert (ss != NULL);
1507 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1514 /* Scalar expression. Evaluate this now. This includes elemental
1515 dimension indices, but not array section bounds. */
1516 gfc_init_se (&se, NULL);
1517 gfc_conv_expr (&se, ss->expr);
1518 gfc_add_block_to_block (&loop->pre, &se.pre);
1520 if (ss->expr->ts.type != BT_CHARACTER)
1522 /* Move the evaluation of scalar expressions outside the
1523 scalarization loop. */
1525 se.expr = convert(gfc_array_index_type, se.expr);
1526 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1527 gfc_add_block_to_block (&loop->pre, &se.post);
1530 gfc_add_block_to_block (&loop->post, &se.post);
1532 ss->data.scalar.expr = se.expr;
1533 ss->string_length = se.string_length;
1536 case GFC_SS_REFERENCE:
1537 /* Scalar reference. Evaluate this now. */
1538 gfc_init_se (&se, NULL);
1539 gfc_conv_expr_reference (&se, ss->expr);
1540 gfc_add_block_to_block (&loop->pre, &se.pre);
1541 gfc_add_block_to_block (&loop->post, &se.post);
1543 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1544 ss->string_length = se.string_length;
1547 case GFC_SS_SECTION:
1548 /* Add the expressions for scalar and vector subscripts. */
1549 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1550 if (ss->data.info.subscript[n])
1551 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1553 gfc_set_vector_loop_bounds (loop, &ss->data.info);
1557 /* Get the vector's descriptor and store it in SS. */
1558 gfc_init_se (&se, NULL);
1559 gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1560 gfc_add_block_to_block (&loop->pre, &se.pre);
1561 gfc_add_block_to_block (&loop->post, &se.post);
1562 ss->data.info.descriptor = se.expr;
1565 case GFC_SS_INTRINSIC:
1566 gfc_add_intrinsic_ss_code (loop, ss);
1569 case GFC_SS_FUNCTION:
1570 /* Array function return value. We call the function and save its
1571 result in a temporary for use inside the loop. */
1572 gfc_init_se (&se, NULL);
1575 gfc_conv_expr (&se, ss->expr);
1576 gfc_add_block_to_block (&loop->pre, &se.pre);
1577 gfc_add_block_to_block (&loop->post, &se.post);
1578 ss->string_length = se.string_length;
1581 case GFC_SS_CONSTRUCTOR:
1582 gfc_trans_array_constructor (loop, ss);
1586 case GFC_SS_COMPONENT:
1587 /* Do nothing. These are handled elsewhere. */
1597 /* Translate expressions for the descriptor and data pointer of a SS. */
1601 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1606 /* Get the descriptor for the array to be scalarized. */
1607 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1608 gfc_init_se (&se, NULL);
1609 se.descriptor_only = 1;
1610 gfc_conv_expr_lhs (&se, ss->expr);
1611 gfc_add_block_to_block (block, &se.pre);
1612 ss->data.info.descriptor = se.expr;
1613 ss->string_length = se.string_length;
1617 /* Also the data pointer. */
1618 tmp = gfc_conv_array_data (se.expr);
1619 /* If this is a variable or address of a variable we use it directly.
1620 Otherwise we must evaluate it now to avoid breaking dependency
1621 analysis by pulling the expressions for elemental array indices
1624 || (TREE_CODE (tmp) == ADDR_EXPR
1625 && DECL_P (TREE_OPERAND (tmp, 0)))))
1626 tmp = gfc_evaluate_now (tmp, block);
1627 ss->data.info.data = tmp;
1629 tmp = gfc_conv_array_offset (se.expr);
1630 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1635 /* Initialize a gfc_loopinfo structure. */
1638 gfc_init_loopinfo (gfc_loopinfo * loop)
1642 memset (loop, 0, sizeof (gfc_loopinfo));
1643 gfc_init_block (&loop->pre);
1644 gfc_init_block (&loop->post);
1646 /* Initially scalarize in order. */
1647 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1650 loop->ss = gfc_ss_terminator;
1654 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1658 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1664 /* Return an expression for the data pointer of an array. */
1667 gfc_conv_array_data (tree descriptor)
1671 type = TREE_TYPE (descriptor);
1672 if (GFC_ARRAY_TYPE_P (type))
1674 if (TREE_CODE (type) == POINTER_TYPE)
1678 /* Descriptorless arrays. */
1679 return build_fold_addr_expr (descriptor);
1683 return gfc_conv_descriptor_data_get (descriptor);
1687 /* Return an expression for the base offset of an array. */
1690 gfc_conv_array_offset (tree descriptor)
1694 type = TREE_TYPE (descriptor);
1695 if (GFC_ARRAY_TYPE_P (type))
1696 return GFC_TYPE_ARRAY_OFFSET (type);
1698 return gfc_conv_descriptor_offset (descriptor);
1702 /* Get an expression for the array stride. */
1705 gfc_conv_array_stride (tree descriptor, int dim)
1710 type = TREE_TYPE (descriptor);
1712 /* For descriptorless arrays use the array size. */
1713 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1714 if (tmp != NULL_TREE)
1717 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1722 /* Like gfc_conv_array_stride, but for the lower bound. */
1725 gfc_conv_array_lbound (tree descriptor, int dim)
1730 type = TREE_TYPE (descriptor);
1732 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1733 if (tmp != NULL_TREE)
1736 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1741 /* Like gfc_conv_array_stride, but for the upper bound. */
1744 gfc_conv_array_ubound (tree descriptor, int dim)
1749 type = TREE_TYPE (descriptor);
1751 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1752 if (tmp != NULL_TREE)
1755 /* This should only ever happen when passing an assumed shape array
1756 as an actual parameter. The value will never be used. */
1757 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1758 return gfc_index_zero_node;
1760 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1765 /* Generate code to perform an array index bound check. */
1768 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1774 if (!flag_bounds_check)
1777 index = gfc_evaluate_now (index, &se->pre);
1778 /* Check lower bound. */
1779 tmp = gfc_conv_array_lbound (descriptor, n);
1780 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1781 /* Check upper bound. */
1782 tmp = gfc_conv_array_ubound (descriptor, n);
1783 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1784 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1786 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1792 /* Return the offset for an index. Performs bound checking for elemental
1793 dimensions. Single element references are processed separately. */
1796 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1797 gfc_array_ref * ar, tree stride)
1803 /* Get the index into the array for this dimension. */
1806 gcc_assert (ar->type != AR_ELEMENT);
1807 switch (ar->dimen_type[dim])
1810 gcc_assert (i == -1);
1811 /* Elemental dimension. */
1812 gcc_assert (info->subscript[dim]
1813 && info->subscript[dim]->type == GFC_SS_SCALAR);
1814 /* We've already translated this value outside the loop. */
1815 index = info->subscript[dim]->data.scalar.expr;
1818 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1822 gcc_assert (info && se->loop);
1823 gcc_assert (info->subscript[dim]
1824 && info->subscript[dim]->type == GFC_SS_VECTOR);
1825 desc = info->subscript[dim]->data.info.descriptor;
1827 /* Get a zero-based index into the vector. */
1828 index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1829 se->loop->loopvar[i], se->loop->from[i]);
1831 /* Multiply the index by the stride. */
1832 index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1833 index, gfc_conv_array_stride (desc, 0));
1835 /* Read the vector to get an index into info->descriptor. */
1836 data = build_fold_indirect_ref (gfc_conv_array_data (desc));
1837 index = gfc_build_array_ref (data, index);
1838 index = gfc_evaluate_now (index, &se->pre);
1840 /* Do any bounds checking on the final info->descriptor index. */
1841 index = gfc_trans_array_bound_check (se, info->descriptor,
1846 /* Scalarized dimension. */
1847 gcc_assert (info && se->loop);
1849 /* Multiply the loop variable by the stride and delta. */
1850 index = se->loop->loopvar[i];
1851 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1853 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1863 /* Temporary array or derived type component. */
1864 gcc_assert (se->loop);
1865 index = se->loop->loopvar[se->loop->order[i]];
1866 if (!integer_zerop (info->delta[i]))
1867 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1868 index, info->delta[i]);
1871 /* Multiply by the stride. */
1872 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1878 /* Build a scalarized reference to an array. */
1881 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1888 info = &se->ss->data.info;
1890 n = se->loop->order[0];
1894 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1896 /* Add the offset for this dimension to the stored offset for all other
1898 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1900 tmp = build_fold_indirect_ref (info->data);
1901 se->expr = gfc_build_array_ref (tmp, index);
1905 /* Translate access of temporary array. */
1908 gfc_conv_tmp_array_ref (gfc_se * se)
1910 se->string_length = se->ss->string_length;
1911 gfc_conv_scalarized_array_ref (se, NULL);
1915 /* Build an array reference. se->expr already holds the array descriptor.
1916 This should be either a variable, indirect variable reference or component
1917 reference. For arrays which do not have a descriptor, se->expr will be
1919 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1922 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1931 /* Handle scalarized references separately. */
1932 if (ar->type != AR_ELEMENT)
1934 gfc_conv_scalarized_array_ref (se, ar);
1935 gfc_advance_se_ss_chain (se);
1939 index = gfc_index_zero_node;
1941 fault = gfc_index_zero_node;
1943 /* Calculate the offsets from all the dimensions. */
1944 for (n = 0; n < ar->dimen; n++)
1946 /* Calculate the index for this dimension. */
1947 gfc_init_se (&indexse, se);
1948 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1949 gfc_add_block_to_block (&se->pre, &indexse.pre);
1951 if (flag_bounds_check)
1953 /* Check array bounds. */
1956 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1958 tmp = gfc_conv_array_lbound (se->expr, n);
1959 cond = fold_build2 (LT_EXPR, boolean_type_node,
1962 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1964 tmp = gfc_conv_array_ubound (se->expr, n);
1965 cond = fold_build2 (GT_EXPR, boolean_type_node,
1968 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1971 /* Multiply the index by the stride. */
1972 stride = gfc_conv_array_stride (se->expr, n);
1973 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1976 /* And add it to the total. */
1977 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1980 if (flag_bounds_check)
1981 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1983 tmp = gfc_conv_array_offset (se->expr);
1984 if (!integer_zerop (tmp))
1985 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1987 /* Access the calculated element. */
1988 tmp = gfc_conv_array_data (se->expr);
1989 tmp = build_fold_indirect_ref (tmp);
1990 se->expr = gfc_build_array_ref (tmp, index);
1994 /* Generate the code to be executed immediately before entering a
1995 scalarization loop. */
1998 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1999 stmtblock_t * pblock)
2008 /* This code will be executed before entering the scalarization loop
2009 for this dimension. */
2010 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2012 if ((ss->useflags & flag) == 0)
2015 if (ss->type != GFC_SS_SECTION
2016 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2017 && ss->type != GFC_SS_COMPONENT)
2020 info = &ss->data.info;
2022 if (dim >= info->dimen)
2025 if (dim == info->dimen - 1)
2027 /* For the outermost loop calculate the offset due to any
2028 elemental dimensions. It will have been initialized with the
2029 base offset of the array. */
2032 for (i = 0; i < info->ref->u.ar.dimen; i++)
2034 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2037 gfc_init_se (&se, NULL);
2039 se.expr = info->descriptor;
2040 stride = gfc_conv_array_stride (info->descriptor, i);
2041 index = gfc_conv_array_index_offset (&se, info, i, -1,
2044 gfc_add_block_to_block (pblock, &se.pre);
2046 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2047 info->offset, index);
2048 info->offset = gfc_evaluate_now (info->offset, pblock);
2052 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2055 stride = gfc_conv_array_stride (info->descriptor, 0);
2057 /* Calculate the stride of the innermost loop. Hopefully this will
2058 allow the backend optimizers to do their stuff more effectively.
2060 info->stride0 = gfc_evaluate_now (stride, pblock);
2064 /* Add the offset for the previous loop dimension. */
2069 ar = &info->ref->u.ar;
2070 i = loop->order[dim + 1];
2078 gfc_init_se (&se, NULL);
2080 se.expr = info->descriptor;
2081 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2082 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2084 gfc_add_block_to_block (pblock, &se.pre);
2085 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2086 info->offset, index);
2087 info->offset = gfc_evaluate_now (info->offset, pblock);
2090 /* Remember this offset for the second loop. */
2091 if (dim == loop->temp_dim - 1)
2092 info->saved_offset = info->offset;
2097 /* Start a scalarized expression. Creates a scope and declares loop
2101 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2107 gcc_assert (!loop->array_parameter);
2109 for (dim = loop->dimen - 1; dim >= 0; dim--)
2111 n = loop->order[dim];
2113 gfc_start_block (&loop->code[n]);
2115 /* Create the loop variable. */
2116 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2118 if (dim < loop->temp_dim)
2122 /* Calculate values that will be constant within this loop. */
2123 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2125 gfc_start_block (pbody);
2129 /* Generates the actual loop code for a scalarization loop. */
2132 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2133 stmtblock_t * pbody)
2141 loopbody = gfc_finish_block (pbody);
2143 /* Initialize the loopvar. */
2144 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2146 exit_label = gfc_build_label_decl (NULL_TREE);
2148 /* Generate the loop body. */
2149 gfc_init_block (&block);
2151 /* The exit condition. */
2152 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2153 tmp = build1_v (GOTO_EXPR, exit_label);
2154 TREE_USED (exit_label) = 1;
2155 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2156 gfc_add_expr_to_block (&block, tmp);
2158 /* The main body. */
2159 gfc_add_expr_to_block (&block, loopbody);
2161 /* Increment the loopvar. */
2162 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2163 loop->loopvar[n], gfc_index_one_node);
2164 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2166 /* Build the loop. */
2167 tmp = gfc_finish_block (&block);
2168 tmp = build1_v (LOOP_EXPR, tmp);
2169 gfc_add_expr_to_block (&loop->code[n], tmp);
2171 /* Add the exit label. */
2172 tmp = build1_v (LABEL_EXPR, exit_label);
2173 gfc_add_expr_to_block (&loop->code[n], tmp);
2177 /* Finishes and generates the loops for a scalarized expression. */
2180 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2185 stmtblock_t *pblock;
2189 /* Generate the loops. */
2190 for (dim = 0; dim < loop->dimen; dim++)
2192 n = loop->order[dim];
2193 gfc_trans_scalarized_loop_end (loop, n, pblock);
2194 loop->loopvar[n] = NULL_TREE;
2195 pblock = &loop->code[n];
2198 tmp = gfc_finish_block (pblock);
2199 gfc_add_expr_to_block (&loop->pre, tmp);
2201 /* Clear all the used flags. */
2202 for (ss = loop->ss; ss; ss = ss->loop_chain)
2207 /* Finish the main body of a scalarized expression, and start the secondary
2211 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2215 stmtblock_t *pblock;
2219 /* We finish as many loops as are used by the temporary. */
2220 for (dim = 0; dim < loop->temp_dim - 1; dim++)
2222 n = loop->order[dim];
2223 gfc_trans_scalarized_loop_end (loop, n, pblock);
2224 loop->loopvar[n] = NULL_TREE;
2225 pblock = &loop->code[n];
2228 /* We don't want to finish the outermost loop entirely. */
2229 n = loop->order[loop->temp_dim - 1];
2230 gfc_trans_scalarized_loop_end (loop, n, pblock);
2232 /* Restore the initial offsets. */
2233 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2235 if ((ss->useflags & 2) == 0)
2238 if (ss->type != GFC_SS_SECTION
2239 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2240 && ss->type != GFC_SS_COMPONENT)
2243 ss->data.info.offset = ss->data.info.saved_offset;
2246 /* Restart all the inner loops we just finished. */
2247 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2249 n = loop->order[dim];
2251 gfc_start_block (&loop->code[n]);
2253 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2255 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2258 /* Start a block for the secondary copying code. */
2259 gfc_start_block (body);
2263 /* Calculate the upper bound of an array section. */
2266 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2275 gcc_assert (ss->type == GFC_SS_SECTION);
2277 info = &ss->data.info;
2280 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2281 /* We'll calculate the upper bound once we have access to the
2282 vector's descriptor. */
2285 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2286 desc = info->descriptor;
2287 end = info->ref->u.ar.end[dim];
2291 /* The upper bound was specified. */
2292 gfc_init_se (&se, NULL);
2293 gfc_conv_expr_type (&se, end, gfc_array_index_type);
2294 gfc_add_block_to_block (pblock, &se.pre);
2299 /* No upper bound was specified, so use the bound of the array. */
2300 bound = gfc_conv_array_ubound (desc, dim);
2307 /* Calculate the lower bound of an array section. */
2310 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2319 gcc_assert (ss->type == GFC_SS_SECTION);
2321 info = &ss->data.info;
2324 if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2326 /* We use a zero-based index to access the vector. */
2327 info->start[n] = gfc_index_zero_node;
2328 info->stride[n] = gfc_index_one_node;
2332 gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2333 desc = info->descriptor;
2334 start = info->ref->u.ar.start[dim];
2335 stride = info->ref->u.ar.stride[dim];
2337 /* Calculate the start of the range. For vector subscripts this will
2338 be the range of the vector. */
2341 /* Specified section start. */
2342 gfc_init_se (&se, NULL);
2343 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2344 gfc_add_block_to_block (&loop->pre, &se.pre);
2345 info->start[n] = se.expr;
2349 /* No lower bound specified so use the bound of the array. */
2350 info->start[n] = gfc_conv_array_lbound (desc, dim);
2352 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2354 /* Calculate the stride. */
2356 info->stride[n] = gfc_index_one_node;
2359 gfc_init_se (&se, NULL);
2360 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2361 gfc_add_block_to_block (&loop->pre, &se.pre);
2362 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2367 /* Calculates the range start and stride for a SS chain. Also gets the
2368 descriptor and data pointer. The range of vector subscripts is the size
2369 of the vector. Array bounds are also checked. */
2372 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2380 /* Determine the rank of the loop. */
2382 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2386 case GFC_SS_SECTION:
2387 case GFC_SS_CONSTRUCTOR:
2388 case GFC_SS_FUNCTION:
2389 case GFC_SS_COMPONENT:
2390 loop->dimen = ss->data.info.dimen;
2393 /* As usual, lbound and ubound are exceptions!. */
2394 case GFC_SS_INTRINSIC:
2395 switch (ss->expr->value.function.isym->generic_id)
2397 case GFC_ISYM_LBOUND:
2398 case GFC_ISYM_UBOUND:
2399 loop->dimen = ss->data.info.dimen;
2410 if (loop->dimen == 0)
2411 gfc_todo_error ("Unable to determine rank of expression");
2414 /* Loop over all the SS in the chain. */
2415 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2417 if (ss->expr && ss->expr->shape && !ss->shape)
2418 ss->shape = ss->expr->shape;
2422 case GFC_SS_SECTION:
2423 /* Get the descriptor for the array. */
2424 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2426 for (n = 0; n < ss->data.info.dimen; n++)
2427 gfc_conv_section_startstride (loop, ss, n);
2430 case GFC_SS_INTRINSIC:
2431 switch (ss->expr->value.function.isym->generic_id)
2433 /* Fall through to supply start and stride. */
2434 case GFC_ISYM_LBOUND:
2435 case GFC_ISYM_UBOUND:
2441 case GFC_SS_CONSTRUCTOR:
2442 case GFC_SS_FUNCTION:
2443 for (n = 0; n < ss->data.info.dimen; n++)
2445 ss->data.info.start[n] = gfc_index_zero_node;
2446 ss->data.info.stride[n] = gfc_index_one_node;
2455 /* The rest is just runtime bound checking. */
2456 if (flag_bounds_check)
2462 tree size[GFC_MAX_DIMENSIONS];
2466 gfc_start_block (&block);
2468 fault = boolean_false_node;
2469 for (n = 0; n < loop->dimen; n++)
2470 size[n] = NULL_TREE;
2472 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2474 if (ss->type != GFC_SS_SECTION)
2477 /* TODO: range checking for mapped dimensions. */
2478 info = &ss->data.info;
2480 /* This code only checks ranges. Elemental and vector
2481 dimensions are checked later. */
2482 for (n = 0; n < loop->dimen; n++)
2485 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2488 desc = ss->data.info.descriptor;
2490 /* Check lower bound. */
2491 bound = gfc_conv_array_lbound (desc, dim);
2492 tmp = info->start[n];
2493 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2494 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2497 /* Check the upper bound. */
2498 bound = gfc_conv_array_ubound (desc, dim);
2499 end = gfc_conv_section_upper_bound (ss, n, &block);
2500 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2501 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2504 /* Check the section sizes match. */
2505 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2507 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2509 /* We remember the size of the first section, and check all the
2510 others against this. */
2514 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2516 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2519 size[n] = gfc_evaluate_now (tmp, &block);
2522 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2524 tmp = gfc_finish_block (&block);
2525 gfc_add_expr_to_block (&loop->pre, tmp);
2530 /* Return true if the two SS could be aliased, i.e. both point to the same data
2532 /* TODO: resolve aliases based on frontend expressions. */
2535 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2542 lsym = lss->expr->symtree->n.sym;
2543 rsym = rss->expr->symtree->n.sym;
2544 if (gfc_symbols_could_alias (lsym, rsym))
2547 if (rsym->ts.type != BT_DERIVED
2548 && lsym->ts.type != BT_DERIVED)
2551 /* For derived types we must check all the component types. We can ignore
2552 array references as these will have the same base type as the previous
2554 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2556 if (lref->type != REF_COMPONENT)
2559 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2562 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2565 if (rref->type != REF_COMPONENT)
2568 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2573 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2575 if (rref->type != REF_COMPONENT)
2578 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2586 /* Resolve array data dependencies. Creates a temporary if required. */
2587 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2591 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2601 loop->temp_ss = NULL;
2602 aref = dest->data.info.ref;
2605 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2607 if (ss->type != GFC_SS_SECTION)
2610 if (gfc_could_be_alias (dest, ss)
2611 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
2617 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2619 lref = dest->expr->ref;
2620 rref = ss->expr->ref;
2622 nDepend = gfc_dep_resolver (lref, rref);
2624 /* TODO : loop shifting. */
2627 /* Mark the dimensions for LOOP SHIFTING */
2628 for (n = 0; n < loop->dimen; n++)
2630 int dim = dest->data.info.dim[n];
2632 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2634 else if (! gfc_is_same_range (&lref->u.ar,
2635 &rref->u.ar, dim, 0))
2639 /* Put all the dimensions with dependencies in the
2642 for (n = 0; n < loop->dimen; n++)
2644 gcc_assert (loop->order[n] == n);
2646 loop->order[dim++] = n;
2649 for (n = 0; n < loop->dimen; n++)
2652 loop->order[dim++] = n;
2655 gcc_assert (dim == loop->dimen);
2664 tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
2665 if (GFC_ARRAY_TYPE_P (base_type)
2666 || GFC_DESCRIPTOR_TYPE_P (base_type))
2667 base_type = gfc_get_element_type (base_type);
2668 loop->temp_ss = gfc_get_ss ();
2669 loop->temp_ss->type = GFC_SS_TEMP;
2670 loop->temp_ss->data.temp.type = base_type;
2671 loop->temp_ss->string_length = dest->string_length;
2672 loop->temp_ss->data.temp.dimen = loop->dimen;
2673 loop->temp_ss->next = gfc_ss_terminator;
2674 gfc_add_ss_to_loop (loop, loop->temp_ss);
2677 loop->temp_ss = NULL;
2681 /* Initialize the scalarization loop. Creates the loop variables. Determines
2682 the range of the loop variables. Creates a temporary if required.
2683 Calculates how to transform from loop variables to array indices for each
2684 expression. Also generates code for scalar expressions which have been
2685 moved outside the loop. */
2688 gfc_conv_loop_setup (gfc_loopinfo * loop)
2693 gfc_ss_info *specinfo;
2697 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2698 bool dynamic[GFC_MAX_DIMENSIONS];
2704 for (n = 0; n < loop->dimen; n++)
2708 /* We use one SS term, and use that to determine the bounds of the
2709 loop for this dimension. We try to pick the simplest term. */
2710 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2714 /* The frontend has worked out the size for us. */
2719 if (ss->type == GFC_SS_CONSTRUCTOR)
2721 /* An unknown size constructor will always be rank one.
2722 Higher rank constructors will either have known shape,
2723 or still be wrapped in a call to reshape. */
2724 gcc_assert (loop->dimen == 1);
2726 /* Always prefer to use the constructor bounds if the size
2727 can be determined at compile time. Prefer not to otherwise,
2728 since the general case involves realloc, and it's better to
2729 avoid that overhead if possible. */
2730 c = ss->expr->value.constructor;
2731 dynamic[n] = gfc_get_array_constructor_size (&i, c);
2732 if (!dynamic[n] || !loopspec[n])
2737 /* TODO: Pick the best bound if we have a choice between a
2738 function and something else. */
2739 if (ss->type == GFC_SS_FUNCTION)
2745 if (ss->type != GFC_SS_SECTION)
2749 specinfo = &loopspec[n]->data.info;
2752 info = &ss->data.info;
2756 /* Criteria for choosing a loop specifier (most important first):
2757 doesn't need realloc
2763 else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2765 else if (integer_onep (info->stride[n])
2766 && !integer_onep (specinfo->stride[n]))
2768 else if (INTEGER_CST_P (info->stride[n])
2769 && !INTEGER_CST_P (specinfo->stride[n]))
2771 else if (INTEGER_CST_P (info->start[n])
2772 && !INTEGER_CST_P (specinfo->start[n]))
2774 /* We don't work out the upper bound.
2775 else if (INTEGER_CST_P (info->finish[n])
2776 && ! INTEGER_CST_P (specinfo->finish[n]))
2777 loopspec[n] = ss; */
2781 gfc_todo_error ("Unable to find scalarization loop specifier");
2783 info = &loopspec[n]->data.info;
2785 /* Set the extents of this range. */
2786 cshape = loopspec[n]->shape;
2787 if (cshape && INTEGER_CST_P (info->start[n])
2788 && INTEGER_CST_P (info->stride[n]))
2790 loop->from[n] = info->start[n];
2791 mpz_set (i, cshape[n]);
2792 mpz_sub_ui (i, i, 1);
2793 /* To = from + (size - 1) * stride. */
2794 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2795 if (!integer_onep (info->stride[n]))
2796 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2797 tmp, info->stride[n]);
2798 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2799 loop->from[n], tmp);
2803 loop->from[n] = info->start[n];
2804 switch (loopspec[n]->type)
2806 case GFC_SS_CONSTRUCTOR:
2807 /* The upper bound is calculated when we expand the
2809 gcc_assert (loop->to[n] == NULL_TREE);
2812 case GFC_SS_SECTION:
2813 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2817 case GFC_SS_FUNCTION:
2818 /* The loop bound will be set when we generate the call. */
2819 gcc_assert (loop->to[n] == NULL_TREE);
2827 /* Transform everything so we have a simple incrementing variable. */
2828 if (integer_onep (info->stride[n]))
2829 info->delta[n] = gfc_index_zero_node;
2832 /* Set the delta for this section. */
2833 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2834 /* Number of iterations is (end - start + step) / step.
2835 with start = 0, this simplifies to
2837 for (i = 0; i<=last; i++){...}; */
2838 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2839 loop->to[n], loop->from[n]);
2840 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2841 tmp, info->stride[n]);
2842 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2843 /* Make the loop variable start at 0. */
2844 loop->from[n] = gfc_index_zero_node;
2848 /* Add all the scalar code that can be taken out of the loops.
2849 This may include calculating the loop bounds, so do it before
2850 allocating the temporary. */
2851 gfc_add_loop_ss_code (loop, loop->ss, false);
2853 /* If we want a temporary then create it. */
2854 if (loop->temp_ss != NULL)
2856 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2857 tmp = loop->temp_ss->data.temp.type;
2858 len = loop->temp_ss->string_length;
2859 n = loop->temp_ss->data.temp.dimen;
2860 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2861 loop->temp_ss->type = GFC_SS_SECTION;
2862 loop->temp_ss->data.info.dimen = n;
2863 gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
2864 &loop->temp_ss->data.info, tmp, false, true,
2868 for (n = 0; n < loop->temp_dim; n++)
2869 loopspec[loop->order[n]] = NULL;
2873 /* For array parameters we don't have loop variables, so don't calculate the
2875 if (loop->array_parameter)
2878 /* Calculate the translation from loop variables to array indices. */
2879 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2881 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2884 info = &ss->data.info;
2886 for (n = 0; n < info->dimen; n++)
2890 /* If we are specifying the range the delta is already set. */
2891 if (loopspec[n] != ss)
2893 /* Calculate the offset relative to the loop variable.
2894 First multiply by the stride. */
2895 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2896 loop->from[n], info->stride[n]);
2898 /* Then subtract this from our starting value. */
2899 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2900 info->start[n], tmp);
2902 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2909 /* Fills in an array descriptor, and returns the size of the array. The size
2910 will be a simple_val, ie a variable or a constant. Also calculates the
2911 offset of the base. Returns the size of the array.
2915 for (n = 0; n < rank; n++)
2917 a.lbound[n] = specified_lower_bound;
2918 offset = offset + a.lbond[n] * stride;
2920 a.ubound[n] = specified_upper_bound;
2921 a.stride[n] = stride;
2922 size = ubound + size; //size = ubound + 1 - lbound
2923 stride = stride * size;
2930 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2931 gfc_expr ** lower, gfc_expr ** upper,
2932 stmtblock_t * pblock)
2944 stmtblock_t thenblock;
2945 stmtblock_t elseblock;
2950 type = TREE_TYPE (descriptor);
2952 stride = gfc_index_one_node;
2953 offset = gfc_index_zero_node;
2955 /* Set the dtype. */
2956 tmp = gfc_conv_descriptor_dtype (descriptor);
2957 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2959 or_expr = NULL_TREE;
2961 for (n = 0; n < rank; n++)
2963 /* We have 3 possibilities for determining the size of the array:
2964 lower == NULL => lbound = 1, ubound = upper[n]
2965 upper[n] = NULL => lbound = 1, ubound = lower[n]
2966 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2969 /* Set lower bound. */
2970 gfc_init_se (&se, NULL);
2972 se.expr = gfc_index_one_node;
2975 gcc_assert (lower[n]);
2978 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2979 gfc_add_block_to_block (pblock, &se.pre);
2983 se.expr = gfc_index_one_node;
2987 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2988 gfc_add_modify_expr (pblock, tmp, se.expr);
2990 /* Work out the offset for this component. */
2991 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2992 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2994 /* Start the calculation for the size of this dimension. */
2995 size = build2 (MINUS_EXPR, gfc_array_index_type,
2996 gfc_index_one_node, se.expr);
2998 /* Set upper bound. */
2999 gfc_init_se (&se, NULL);
3000 gcc_assert (ubound);
3001 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3002 gfc_add_block_to_block (pblock, &se.pre);
3004 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
3005 gfc_add_modify_expr (pblock, tmp, se.expr);
3007 /* Store the stride. */
3008 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
3009 gfc_add_modify_expr (pblock, tmp, stride);
3011 /* Calculate the size of this dimension. */
3012 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3014 /* Check wether the size for this dimension is negative. */
3015 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3016 gfc_index_zero_node);
3020 or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3022 /* Multiply the stride by the number of elements in this dimension. */
3023 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3024 stride = gfc_evaluate_now (stride, pblock);
3027 /* The stride is the number of elements in the array, so multiply by the
3028 size of an element to get the total size. */
3029 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3030 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
3032 if (poffset != NULL)
3034 offset = gfc_evaluate_now (offset, pblock);
3038 var = gfc_create_var (TREE_TYPE (size), "size");
3039 gfc_start_block (&thenblock);
3040 gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
3041 thencase = gfc_finish_block (&thenblock);
3043 gfc_start_block (&elseblock);
3044 gfc_add_modify_expr (&elseblock, var, size);
3045 elsecase = gfc_finish_block (&elseblock);
3047 tmp = gfc_evaluate_now (or_expr, pblock);
3048 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
3049 gfc_add_expr_to_block (pblock, tmp);
3055 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
3056 the work for an ALLOCATE statement. */
3060 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
3070 int allocatable_array;
3074 /* Find the last reference in the chain. */
3075 while (ref && ref->next != NULL)
3077 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3081 if (ref == NULL || ref->type != REF_ARRAY)
3084 /* Figure out the size of the array. */
3085 switch (ref->u.ar.type)
3089 upper = ref->u.ar.start;
3093 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
3095 lower = ref->u.ar.as->lower;
3096 upper = ref->u.ar.as->upper;
3100 lower = ref->u.ar.start;
3101 upper = ref->u.ar.end;
3109 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
3110 lower, upper, &se->pre);
3112 /* Allocate memory to store the data. */
3113 tmp = gfc_conv_descriptor_data_addr (se->expr);
3114 pointer = gfc_evaluate_now (tmp, &se->pre);
3116 allocatable_array = expr->symtree->n.sym->attr.allocatable;
3118 if (TYPE_PRECISION (gfc_array_index_type) == 32)
3120 if (allocatable_array)
3121 allocate = gfor_fndecl_allocate_array;
3123 allocate = gfor_fndecl_allocate;
3125 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
3127 if (allocatable_array)
3128 allocate = gfor_fndecl_allocate64_array;
3130 allocate = gfor_fndecl_allocate64;
3135 tmp = gfc_chainon_list (NULL_TREE, pointer);
3136 tmp = gfc_chainon_list (tmp, size);
3137 tmp = gfc_chainon_list (tmp, pstat);
3138 tmp = build_function_call_expr (allocate, tmp);
3139 gfc_add_expr_to_block (&se->pre, tmp);
3141 tmp = gfc_conv_descriptor_offset (se->expr);
3142 gfc_add_modify_expr (&se->pre, tmp, offset);
3148 /* Deallocate an array variable. Also used when an allocated variable goes
3153 gfc_array_deallocate (tree descriptor, tree pstat)
3159 gfc_start_block (&block);
3160 /* Get a pointer to the data. */
3161 tmp = gfc_conv_descriptor_data_addr (descriptor);
3162 var = gfc_evaluate_now (tmp, &block);
3164 /* Parameter is the address of the data component. */
3165 tmp = gfc_chainon_list (NULL_TREE, var);
3166 tmp = gfc_chainon_list (tmp, pstat);
3167 tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
3168 gfc_add_expr_to_block (&block, tmp);
3170 return gfc_finish_block (&block);
3174 /* Create an array constructor from an initialization expression.
3175 We assume the frontend already did any expansions and conversions. */
3178 gfc_conv_array_initializer (tree type, gfc_expr * expr)
3185 unsigned HOST_WIDE_INT lo;
3187 VEC(constructor_elt,gc) *v = NULL;
3189 switch (expr->expr_type)
3192 case EXPR_STRUCTURE:
3193 /* A single scalar or derived type value. Create an array with all
3194 elements equal to that value. */
3195 gfc_init_se (&se, NULL);
3197 if (expr->expr_type == EXPR_CONSTANT)
3198 gfc_conv_constant (&se, expr);
3200 gfc_conv_structure (&se, expr, 1);
3202 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3203 gcc_assert (tmp && INTEGER_CST_P (tmp));
3204 hi = TREE_INT_CST_HIGH (tmp);
3205 lo = TREE_INT_CST_LOW (tmp);
3209 /* This will probably eat buckets of memory for large arrays. */
3210 while (hi != 0 || lo != 0)
3212 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3220 /* Create a vector of all the elements. */
3221 for (c = expr->value.constructor; c; c = c->next)
3225 /* Problems occur when we get something like
3226 integer :: a(lots) = (/(i, i=1,lots)/) */
3227 /* TODO: Unexpanded array initializers. */
3229 ("Possible frontend bug: array constructor not expanded");
3231 if (mpz_cmp_si (c->n.offset, 0) != 0)
3232 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3236 if (mpz_cmp_si (c->repeat, 0) != 0)
3240 mpz_set (maxval, c->repeat);
3241 mpz_add (maxval, c->n.offset, maxval);
3242 mpz_sub_ui (maxval, maxval, 1);
3243 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3244 if (mpz_cmp_si (c->n.offset, 0) != 0)
3246 mpz_add_ui (maxval, c->n.offset, 1);
3247 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3250 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3252 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3258 gfc_init_se (&se, NULL);
3259 switch (c->expr->expr_type)
3262 gfc_conv_constant (&se, c->expr);
3263 if (range == NULL_TREE)
3264 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3267 if (index != NULL_TREE)
3268 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3269 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3273 case EXPR_STRUCTURE:
3274 gfc_conv_structure (&se, c->expr, 1);
3275 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3288 /* Create a constructor from the list of elements. */
3289 tmp = build_constructor (type, v);
3290 TREE_CONSTANT (tmp) = 1;
3291 TREE_INVARIANT (tmp) = 1;
3296 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
3297 returns the size (in elements) of the array. */
3300 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3301 stmtblock_t * pblock)
3316 size = gfc_index_one_node;
3317 offset = gfc_index_zero_node;
3318 for (dim = 0; dim < as->rank; dim++)
3320 /* Evaluate non-constant array bound expressions. */
3321 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3322 if (as->lower[dim] && !INTEGER_CST_P (lbound))
3324 gfc_init_se (&se, NULL);
3325 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3326 gfc_add_block_to_block (pblock, &se.pre);
3327 gfc_add_modify_expr (pblock, lbound, se.expr);
3329 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3330 if (as->upper[dim] && !INTEGER_CST_P (ubound))
3332 gfc_init_se (&se, NULL);
3333 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3334 gfc_add_block_to_block (pblock, &se.pre);
3335 gfc_add_modify_expr (pblock, ubound, se.expr);
3337 /* The offset of this dimension. offset = offset - lbound * stride. */
3338 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3339 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3341 /* The size of this dimension, and the stride of the next. */
3342 if (dim + 1 < as->rank)
3343 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3345 stride = GFC_TYPE_ARRAY_SIZE (type);
3347 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3349 /* Calculate stride = size * (ubound + 1 - lbound). */
3350 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3351 gfc_index_one_node, lbound);
3352 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3353 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3355 gfc_add_modify_expr (pblock, stride, tmp);
3357 stride = gfc_evaluate_now (tmp, pblock);
3363 gfc_trans_vla_type_sizes (sym, pblock);
3370 /* Generate code to initialize/allocate an array variable. */
3373 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3383 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3385 /* Do nothing for USEd variables. */
3386 if (sym->attr.use_assoc)
3389 type = TREE_TYPE (decl);
3390 gcc_assert (GFC_ARRAY_TYPE_P (type));
3391 onstack = TREE_CODE (type) != POINTER_TYPE;
3393 gfc_start_block (&block);
3395 /* Evaluate character string length. */
3396 if (sym->ts.type == BT_CHARACTER
3397 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3399 gfc_trans_init_string_length (sym->ts.cl, &block);
3401 gfc_trans_vla_type_sizes (sym, &block);
3403 /* Emit a DECL_EXPR for this variable, which will cause the
3404 gimplifier to allocate storage, and all that good stuff. */
3405 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3406 gfc_add_expr_to_block (&block, tmp);
3411 gfc_add_expr_to_block (&block, fnbody);
3412 return gfc_finish_block (&block);
3415 type = TREE_TYPE (type);
3417 gcc_assert (!sym->attr.use_assoc);
3418 gcc_assert (!TREE_STATIC (decl));
3419 gcc_assert (!sym->module);
3421 if (sym->ts.type == BT_CHARACTER
3422 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3423 gfc_trans_init_string_length (sym->ts.cl, &block);
3425 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3427 /* Don't actually allocate space for Cray Pointees. */
3428 if (sym->attr.cray_pointee)
3430 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3431 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3432 gfc_add_expr_to_block (&block, fnbody);
3433 return gfc_finish_block (&block);
3436 /* The size is the number of elements in the array, so multiply by the
3437 size of an element to get the total size. */
3438 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3439 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3441 /* Allocate memory to hold the data. */
3442 tmp = gfc_chainon_list (NULL_TREE, size);
3444 if (gfc_index_integer_kind == 4)
3445 fndecl = gfor_fndecl_internal_malloc;
3446 else if (gfc_index_integer_kind == 8)
3447 fndecl = gfor_fndecl_internal_malloc64;
3450 tmp = build_function_call_expr (fndecl, tmp);
3451 tmp = fold (convert (TREE_TYPE (decl), tmp));
3452 gfc_add_modify_expr (&block, decl, tmp);
3454 /* Set offset of the array. */
3455 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3456 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3459 /* Automatic arrays should not have initializers. */
3460 gcc_assert (!sym->value);
3462 gfc_add_expr_to_block (&block, fnbody);
3464 /* Free the temporary. */
3465 tmp = convert (pvoid_type_node, decl);
3466 tmp = gfc_chainon_list (NULL_TREE, tmp);
3467 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3468 gfc_add_expr_to_block (&block, tmp);
3470 return gfc_finish_block (&block);
3474 /* Generate entry and exit code for g77 calling convention arrays. */
3477 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3486 gfc_get_backend_locus (&loc);
3487 gfc_set_backend_locus (&sym->declared_at);
3489 /* Descriptor type. */
3490 parm = sym->backend_decl;
3491 type = TREE_TYPE (parm);
3492 gcc_assert (GFC_ARRAY_TYPE_P (type));
3494 gfc_start_block (&block);
3496 if (sym->ts.type == BT_CHARACTER
3497 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3498 gfc_trans_init_string_length (sym->ts.cl, &block);
3500 /* Evaluate the bounds of the array. */
3501 gfc_trans_array_bounds (type, sym, &offset, &block);
3503 /* Set the offset. */
3504 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3505 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3507 /* Set the pointer itself if we aren't using the parameter directly. */
3508 if (TREE_CODE (parm) != PARM_DECL)
3510 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3511 gfc_add_modify_expr (&block, parm, tmp);
3513 tmp = gfc_finish_block (&block);
3515 gfc_set_backend_locus (&loc);
3517 gfc_start_block (&block);
3518 /* Add the initialization code to the start of the function. */
3519 gfc_add_expr_to_block (&block, tmp);
3520 gfc_add_expr_to_block (&block, body);
3522 return gfc_finish_block (&block);
3526 /* Modify the descriptor of an array parameter so that it has the
3527 correct lower bound. Also move the upper bound accordingly.
3528 If the array is not packed, it will be copied into a temporary.
3529 For each dimension we set the new lower and upper bounds. Then we copy the
3530 stride and calculate the offset for this dimension. We also work out
3531 what the stride of a packed array would be, and see it the two match.
3532 If the array need repacking, we set the stride to the values we just
3533 calculated, recalculate the offset and copy the array data.
3534 Code is also added to copy the data back at the end of the function.
3538 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3545 stmtblock_t cleanup;
3563 /* Do nothing for pointer and allocatable arrays. */
3564 if (sym->attr.pointer || sym->attr.allocatable)
3567 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3568 return gfc_trans_g77_array (sym, body);
3570 gfc_get_backend_locus (&loc);
3571 gfc_set_backend_locus (&sym->declared_at);
3573 /* Descriptor type. */
3574 type = TREE_TYPE (tmpdesc);
3575 gcc_assert (GFC_ARRAY_TYPE_P (type));
3576 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3577 dumdesc = build_fold_indirect_ref (dumdesc);
3578 gfc_start_block (&block);
3580 if (sym->ts.type == BT_CHARACTER
3581 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3582 gfc_trans_init_string_length (sym->ts.cl, &block);
3584 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3586 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3587 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3589 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3591 /* For non-constant shape arrays we only check if the first dimension
3592 is contiguous. Repacking higher dimensions wouldn't gain us
3593 anything as we still don't know the array stride. */
3594 partial = gfc_create_var (boolean_type_node, "partial");
3595 TREE_USED (partial) = 1;
3596 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3597 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
3598 gfc_add_modify_expr (&block, partial, tmp);
3602 partial = NULL_TREE;
3605 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3606 here, however I think it does the right thing. */
3609 /* Set the first stride. */
3610 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3611 stride = gfc_evaluate_now (stride, &block);
3613 tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
3614 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3615 gfc_index_one_node, stride);
3616 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3617 gfc_add_modify_expr (&block, stride, tmp);
3619 /* Allow the user to disable array repacking. */
3620 stmt_unpacked = NULL_TREE;
3624 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3625 /* A library call to repack the array if necessary. */
3626 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3627 tmp = gfc_chainon_list (NULL_TREE, tmp);
3628 stmt_unpacked = build_function_call_expr (gfor_fndecl_in_pack, tmp);
3630 stride = gfc_index_one_node;
3633 /* This is for the case where the array data is used directly without
3634 calling the repack function. */
3635 if (no_repack || partial != NULL_TREE)
3636 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3638 stmt_packed = NULL_TREE;
3640 /* Assign the data pointer. */
3641 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3643 /* Don't repack unknown shape arrays when the first stride is 1. */
3644 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3645 stmt_packed, stmt_unpacked);
3648 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3649 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3651 offset = gfc_index_zero_node;
3652 size = gfc_index_one_node;
3654 /* Evaluate the bounds of the array. */
3655 for (n = 0; n < sym->as->rank; n++)
3657 if (checkparm || !sym->as->upper[n])
3659 /* Get the bounds of the actual parameter. */
3660 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3661 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3665 dubound = NULL_TREE;
3666 dlbound = NULL_TREE;
3669 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3670 if (!INTEGER_CST_P (lbound))
3672 gfc_init_se (&se, NULL);
3673 gfc_conv_expr_type (&se, sym->as->lower[n],
3674 gfc_array_index_type);
3675 gfc_add_block_to_block (&block, &se.pre);
3676 gfc_add_modify_expr (&block, lbound, se.expr);
3679 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3680 /* Set the desired upper bound. */
3681 if (sym->as->upper[n])
3683 /* We know what we want the upper bound to be. */
3684 if (!INTEGER_CST_P (ubound))
3686 gfc_init_se (&se, NULL);
3687 gfc_conv_expr_type (&se, sym->as->upper[n],
3688 gfc_array_index_type);
3689 gfc_add_block_to_block (&block, &se.pre);
3690 gfc_add_modify_expr (&block, ubound, se.expr);
3693 /* Check the sizes match. */
3696 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3698 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3700 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3702 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
3703 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3708 /* For assumed shape arrays move the upper bound by the same amount
3709 as the lower bound. */
3710 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
3711 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
3712 gfc_add_modify_expr (&block, ubound, tmp);
3714 /* The offset of this dimension. offset = offset - lbound * stride. */
3715 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3716 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3718 /* The size of this dimension, and the stride of the next. */
3719 if (n + 1 < sym->as->rank)
3721 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3723 if (no_repack || partial != NULL_TREE)
3726 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3729 /* Figure out the stride if not a known constant. */
3730 if (!INTEGER_CST_P (stride))
3733 stmt_packed = NULL_TREE;
3736 /* Calculate stride = size * (ubound + 1 - lbound). */
3737 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3738 gfc_index_one_node, lbound);
3739 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3741 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3746 /* Assign the stride. */
3747 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3748 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3749 stmt_unpacked, stmt_packed);
3751 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3752 gfc_add_modify_expr (&block, stride, tmp);
3757 stride = GFC_TYPE_ARRAY_SIZE (type);
3759 if (stride && !INTEGER_CST_P (stride))
3761 /* Calculate size = stride * (ubound + 1 - lbound). */
3762 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3763 gfc_index_one_node, lbound);
3764 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3766 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3767 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
3768 gfc_add_modify_expr (&block, stride, tmp);
3773 /* Set the offset. */
3774 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3775 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3777 gfc_trans_vla_type_sizes (sym, &block);
3779 stmt = gfc_finish_block (&block);
3781 gfc_start_block (&block);
3783 /* Only do the entry/initialization code if the arg is present. */
3784 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3785 optional_arg = (sym->attr.optional
3786 || (sym->ns->proc_name->attr.entry_master
3787 && sym->attr.dummy));
3790 tmp = gfc_conv_expr_present (sym);
3791 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3793 gfc_add_expr_to_block (&block, stmt);
3795 /* Add the main function body. */
3796 gfc_add_expr_to_block (&block, body);
3801 gfc_start_block (&cleanup);
3803 if (sym->attr.intent != INTENT_IN)
3805 /* Copy the data back. */
3806 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3807 tmp = gfc_chainon_list (tmp, tmpdesc);
3808 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
3809 gfc_add_expr_to_block (&cleanup, tmp);
3812 /* Free the temporary. */
3813 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3814 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
3815 gfc_add_expr_to_block (&cleanup, tmp);
3817 stmt = gfc_finish_block (&cleanup);
3819 /* Only do the cleanup if the array was repacked. */
3820 tmp = build_fold_indirect_ref (dumdesc);
3821 tmp = gfc_conv_descriptor_data_get (tmp);
3822 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3823 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3827 tmp = gfc_conv_expr_present (sym);
3828 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3830 gfc_add_expr_to_block (&block, stmt);
3832 /* We don't need to free any memory allocated by internal_pack as it will
3833 be freed at the end of the function by pop_context. */
3834 return gfc_finish_block (&block);
3838 /* Convert an array for passing as an actual argument. Expressions and
3839 vector subscripts are evaluated and stored in a temporary, which is then
3840 passed. For whole arrays the descriptor is passed. For array sections
3841 a modified copy of the descriptor is passed, but using the original data.
3843 This function is also used for array pointer assignments, and there
3846 - want_pointer && !se->direct_byref
3847 EXPR is an actual argument. On exit, se->expr contains a
3848 pointer to the array descriptor.
3850 - !want_pointer && !se->direct_byref
3851 EXPR is an actual argument to an intrinsic function or the
3852 left-hand side of a pointer assignment. On exit, se->expr
3853 contains the descriptor for EXPR.
3855 - !want_pointer && se->direct_byref
3856 EXPR is the right-hand side of a pointer assignment and
3857 se->expr is the descriptor for the previously-evaluated
3858 left-hand side. The function creates an assignment from
3859 EXPR to se->expr. */
3862 gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3877 gcc_assert (ss != gfc_ss_terminator);
3879 /* TODO: Pass constant array constructors without a temporary. */
3880 /* Special case things we know we can pass easily. */
3881 switch (expr->expr_type)
3884 /* If we have a linear array section, we can pass it directly.
3885 Otherwise we need to copy it into a temporary. */
3887 /* Find the SS for the array section. */
3889 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3890 secss = secss->next;
3892 gcc_assert (secss != gfc_ss_terminator);
3893 info = &secss->data.info;
3895 /* Get the descriptor for the array. */
3896 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3897 desc = info->descriptor;
3899 need_tmp = gfc_ref_needs_temporary_p (expr->ref);
3902 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3904 /* Create a new descriptor if the array doesn't have one. */
3907 else if (info->ref->u.ar.type == AR_FULL)
3909 else if (se->direct_byref)
3914 gcc_assert (ref->u.ar.type == AR_SECTION);
3917 for (n = 0; n < ref->u.ar.dimen; n++)
3919 /* Detect passing the full array as a section. This could do
3920 even more checking, but it doesn't seem worth it. */
3921 if (ref->u.ar.start[n]
3923 || (ref->u.ar.stride[n]
3924 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
3934 if (se->direct_byref)
3936 /* Copy the descriptor for pointer assignments. */
3937 gfc_add_modify_expr (&se->pre, se->expr, desc);
3939 else if (se->want_pointer)
3941 /* We pass full arrays directly. This means that pointers and
3942 allocatable arrays should also work. */
3943 se->expr = build_fold_addr_expr (desc);
3950 if (expr->ts.type == BT_CHARACTER)
3951 se->string_length = gfc_get_expr_charlen (expr);
3958 /* A transformational function return value will be a temporary
3959 array descriptor. We still need to go through the scalarizer
3960 to create the descriptor. Elemental functions ar handled as
3961 arbitrary expressions, i.e. copy to a temporary. */
3963 /* Look for the SS for this function. */
3964 while (secss != gfc_ss_terminator
3965 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3966 secss = secss->next;
3968 if (se->direct_byref)
3970 gcc_assert (secss != gfc_ss_terminator);
3972 /* For pointer assignments pass the descriptor directly. */
3974 se->expr = build_fold_addr_expr (se->expr);
3975 gfc_conv_expr (se, expr);
3979 if (secss == gfc_ss_terminator)
3981 /* Elemental function. */
3987 /* Transformational function. */
3988 info = &secss->data.info;
3994 /* Something complicated. Copy it into a temporary. */
4002 gfc_init_loopinfo (&loop);
4004 /* Associate the SS with the loop. */
4005 gfc_add_ss_to_loop (&loop, ss);
4007 /* Tell the scalarizer not to bother creating loop variables, etc. */
4009 loop.array_parameter = 1;
4011 /* The right-hand side of a pointer assignment mustn't use a temporary. */
4012 gcc_assert (!se->direct_byref);
4014 /* Setup the scalarizing loops and bounds. */
4015 gfc_conv_ss_startstride (&loop);
4019 /* Tell the scalarizer to make a temporary. */
4020 loop.temp_ss = gfc_get_ss ();
4021 loop.temp_ss->type = GFC_SS_TEMP;
4022 loop.temp_ss->next = gfc_ss_terminator;
4023 if (expr->ts.type == BT_CHARACTER)
4026 && expr->ts.cl->length
4027 && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
4029 expr->ts.cl->backend_decl
4030 = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
4031 expr->ts.cl->length->ts.kind);
4032 loop.temp_ss->data.temp.type
4033 = gfc_typenode_for_spec (&expr->ts);
4034 loop.temp_ss->string_length
4035 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
4039 loop.temp_ss->data.temp.type
4040 = gfc_typenode_for_spec (&expr->ts);
4041 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
4043 se->string_length = loop.temp_ss->string_length;
4047 loop.temp_ss->data.temp.type
4048 = gfc_typenode_for_spec (&expr->ts);
4049 loop.temp_ss->string_length = NULL;
4051 loop.temp_ss->data.temp.dimen = loop.dimen;
4052 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4055 gfc_conv_loop_setup (&loop);
4059 /* Copy into a temporary and pass that. We don't need to copy the data
4060 back because expressions and vector subscripts must be INTENT_IN. */
4061 /* TODO: Optimize passing function return values. */
4065 /* Start the copying loops. */
4066 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4067 gfc_mark_ss_chain_used (ss, 1);
4068 gfc_start_scalarized_body (&loop, &block);
4070 /* Copy each data element. */
4071 gfc_init_se (&lse, NULL);
4072 gfc_copy_loopinfo_to_se (&lse, &loop);
4073 gfc_init_se (&rse, NULL);
4074 gfc_copy_loopinfo_to_se (&rse, &loop);
4076 lse.ss = loop.temp_ss;
4079 gfc_conv_scalarized_array_ref (&lse, NULL);
4080 if (expr->ts.type == BT_CHARACTER)
4082 gfc_conv_expr (&rse, expr);
4083 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
4084 rse.expr = build_fold_indirect_ref (rse.expr);
4087 gfc_conv_expr_val (&rse, expr);
4089 gfc_add_block_to_block (&block, &rse.pre);
4090 gfc_add_block_to_block (&block, &lse.pre);
4092 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4094 /* Finish the copying loops. */
4095 gfc_trans_scalarizing_loops (&loop, &block);
4097 /* Set the first stride component to zero to indicate a temporary. */
4098 desc = loop.temp_ss->data.info.descriptor;
4099 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
4100 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4102 gcc_assert (is_gimple_lvalue (desc));
4104 else if (expr->expr_type == EXPR_FUNCTION)
4106 desc = info->descriptor;
4107 se->string_length = ss->string_length;
4111 /* We pass sections without copying to a temporary. Make a new
4112 descriptor and point it at the section we want. The loop variable
4113 limits will be the limits of the section.
4114 A function may decide to repack the array to speed up access, but
4115 we're not bothered about that here. */
4124 /* Set the string_length for a character array. */
4125 if (expr->ts.type == BT_CHARACTER)
4126 se->string_length = gfc_get_expr_charlen (expr);
4128 desc = info->descriptor;
4129 gcc_assert (secss && secss != gfc_ss_terminator);
4130 if (se->direct_byref)
4132 /* For pointer assignments we fill in the destination. */
4134 parmtype = TREE_TYPE (parm);
4138 /* Otherwise make a new one. */
4139 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4140 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
4141 loop.from, loop.to, 0);
4142 parm = gfc_create_var (parmtype, "parm");
4145 offset = gfc_index_zero_node;
4148 /* The following can be somewhat confusing. We have two
4149 descriptors, a new one and the original array.
4150 {parm, parmtype, dim} refer to the new one.
4151 {desc, type, n, secss, loop} refer to the original, which maybe
4152 a descriptorless array.
4153 The bounds of the scalarization are the bounds of the section.
4154 We don't have to worry about numeric overflows when calculating
4155 the offsets because all elements are within the array data. */
4157 /* Set the dtype. */
4158 tmp = gfc_conv_descriptor_dtype (parm);
4159 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
4161 if (se->direct_byref)
4162 base = gfc_index_zero_node;
4166 for (n = 0; n < info->ref->u.ar.dimen; n++)
4168 stride = gfc_conv_array_stride (desc, n);
4170 /* Work out the offset. */
4171 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4173 gcc_assert (info->subscript[n]
4174 && info->subscript[n]->type == GFC_SS_SCALAR);
4175 start = info->subscript[n]->data.scalar.expr;
4179 /* Check we haven't somehow got out of sync. */
4180 gcc_assert (info->dim[dim] == n);
4182 /* Evaluate and remember the start of the section. */
4183 start = info->start[dim];
4184 stride = gfc_evaluate_now (stride, &loop.pre);
4187 tmp = gfc_conv_array_lbound (desc, n);
4188 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
4190 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
4191 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
4193 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
4195 /* For elemental dimensions, we only need the offset. */
4199 /* Vector subscripts need copying and are handled elsewhere. */
4200 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
4202 /* Set the new lower bound. */
4203 from = loop.from[dim];
4206 /* If we have an array section or are assigning to a pointer,
4207 make sure that the lower bound is 1. References to the full
4208 array should otherwise keep the original bounds. */
4209 if ((info->ref->u.ar.type != AR_FULL || se->direct_byref)
4210 && !integer_onep (from))
4212 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4213 gfc_index_one_node, from);
4214 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
4215 from = gfc_index_one_node;
4217 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
4218 gfc_add_modify_expr (&loop.pre, tmp, from);
4220 /* Set the new upper bound. */
4221 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
4222 gfc_add_modify_expr (&loop.pre, tmp, to);
4224 /* Multiply the stride by the section stride to get the
4226 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4227 stride, info->stride[dim]);
4229 if (se->direct_byref)
4230 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
4233 /* Store the new stride. */
4234 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
4235 gfc_add_modify_expr (&loop.pre, tmp, stride);
4240 if (se->data_not_needed)
4241 gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
4244 /* Point the data pointer at the first element in the section. */
4245 tmp = gfc_conv_array_data (desc);
4246 tmp = build_fold_indirect_ref (tmp);
4247 tmp = gfc_build_array_ref (tmp, offset);
4248 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
4249 gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
4252 if (se->direct_byref && !se->data_not_needed)
4254 /* Set the offset. */
4255 tmp = gfc_conv_descriptor_offset (parm);
4256 gfc_add_modify_expr (&loop.pre, tmp, base);
4260 /* Only the callee knows what the correct offset it, so just set
4262 tmp = gfc_conv_descriptor_offset (parm);
4263 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
4268 if (!se->direct_byref)
4270 /* Get a pointer to the new descriptor. */
4271 if (se->want_pointer)
4272 se->expr = build_fold_addr_expr (desc);
4277 gfc_add_block_to_block (&se->pre, &loop.pre);
4278 gfc_add_block_to_block (&se->post, &loop.post);
4280 /* Cleanup the scalarizer. */
4281 gfc_cleanup_loop (&loop);
4285 /* Convert an array for passing as an actual parameter. */
4286 /* TODO: Optimize passing g77 arrays. */
4289 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
4298 /* Passing address of the array if it is not pointer or assumed-shape. */
4299 if (expr->expr_type == EXPR_VARIABLE
4300 && expr->ref->u.ar.type == AR_FULL && g77)
4302 sym = expr->symtree->n.sym;
4303 tmp = gfc_get_symbol_decl (sym);
4305 if (sym->ts.type == BT_CHARACTER)
4306 se->string_length = sym->ts.cl->backend_decl;
4307 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
4308 && !sym->attr.allocatable)
4310 /* Some variables are declared directly, others are declared as
4311 pointers and allocated on the heap. */
4312 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
4315 se->expr = build_fold_addr_expr (tmp);
4318 if (sym->attr.allocatable)
4320 se->expr = gfc_conv_array_data (tmp);
4325 se->want_pointer = 1;
4326 gfc_conv_expr_descriptor (se, expr, ss);
4331 /* Repack the array. */
4332 tmp = gfc_chainon_list (NULL_TREE, desc);
4333 ptr = build_function_call_expr (gfor_fndecl_in_pack, tmp);
4334 ptr = gfc_evaluate_now (ptr, &se->pre);
4337 gfc_start_block (&block);
4339 /* Copy the data back. */
4340 tmp = gfc_chainon_list (NULL_TREE, desc);
4341 tmp = gfc_chainon_list (tmp, ptr);
4342 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
4343 gfc_add_expr_to_block (&block, tmp);
4345 /* Free the temporary. */
4346 tmp = convert (pvoid_type_node, ptr);
4347 tmp = gfc_chainon_list (NULL_TREE, tmp);
4348 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
4349 gfc_add_expr_to_block (&block, tmp);
4351 stmt = gfc_finish_block (&block);
4353 gfc_init_block (&block);
4354 /* Only if it was repacked. This code needs to be executed before the
4355 loop cleanup code. */
4356 tmp = build_fold_indirect_ref (desc);
4357 tmp = gfc_conv_array_data (tmp);
4358 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
4359 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
4361 gfc_add_expr_to_block (&block, tmp);
4362 gfc_add_block_to_block (&block, &se->post);
4364 gfc_init_block (&se->post);
4365 gfc_add_block_to_block (&se->post, &block);
4370 /* Generate code to deallocate an array, if it is allocated. */
4373 gfc_trans_dealloc_allocated (tree descriptor)
4379 gfc_start_block (&block);
4380 deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4382 tmp = gfc_conv_descriptor_data_get (descriptor);
4383 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4384 build_int_cst (TREE_TYPE (tmp), 0));
4385 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4386 gfc_add_expr_to_block (&block, tmp);
4388 tmp = gfc_finish_block (&block);
4394 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
4397 gfc_trans_deferred_array (gfc_symbol * sym, tree body)
4402 stmtblock_t fnblock;
4405 /* Make sure the frontend gets these right. */
4406 if (!(sym->attr.pointer || sym->attr.allocatable))
4408 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4410 gfc_init_block (&fnblock);
4412 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4413 || TREE_CODE (sym->backend_decl) == PARM_DECL);
4415 if (sym->ts.type == BT_CHARACTER
4416 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4418 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
4419 gfc_trans_vla_type_sizes (sym, &fnblock);
4422 /* Dummy and use associated variables don't need anything special. */
4423 if (sym->attr.dummy || sym->attr.use_assoc)
4425 gfc_add_expr_to_block (&fnblock, body);
4427 return gfc_finish_block (&fnblock);
4430 gfc_get_backend_locus (&loc);
4431 gfc_set_backend_locus (&sym->declared_at);
4432 descriptor = sym->backend_decl;
4434 if (TREE_STATIC (descriptor))
4436 /* SAVEd variables are not freed on exit. */
4437 gfc_trans_static_array_pointer (sym);
4441 /* Get the descriptor type. */
4442 type = TREE_TYPE (sym->backend_decl);
4443 if (!GFC_DESCRIPTOR_TYPE_P (type))
4445 /* If the backend_decl is not a descriptor, we must have a pointer
4447 descriptor = build_fold_indirect_ref (sym->backend_decl);
4448 type = TREE_TYPE (descriptor);
4449 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4452 /* NULLIFY the data pointer. */
4453 gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4455 gfc_add_expr_to_block (&fnblock, body);
4457 gfc_set_backend_locus (&loc);
4458 /* Allocatable arrays need to be freed when they go out of scope. */
4459 if (sym->attr.allocatable)
4461 tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4462 gfc_add_expr_to_block (&fnblock, tmp);
4465 return gfc_finish_block (&fnblock);
4468 /************ Expression Walking Functions ******************/
4470 /* Walk a variable reference.
4472 Possible extension - multiple component subscripts.
4473 x(:,:) = foo%a(:)%b(:)
4475 forall (i=..., j=...)
4476 x(i,j) = foo%a(j)%b(i)
4478 This adds a fair amout of complexity because you need to deal with more
4479 than one ref. Maybe handle in a similar manner to vector subscripts.
4480 Maybe not worth the effort. */
4484 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4492 for (ref = expr->ref; ref; ref = ref->next)
4493 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
4496 for (; ref; ref = ref->next)
4498 if (ref->type == REF_SUBSTRING)
4500 newss = gfc_get_ss ();
4501 newss->type = GFC_SS_SCALAR;
4502 newss->expr = ref->u.ss.start;
4506 newss = gfc_get_ss ();
4507 newss->type = GFC_SS_SCALAR;
4508 newss->expr = ref->u.ss.end;
4513 /* We're only interested in array sections from now on. */
4514 if (ref->type != REF_ARRAY)
4521 for (n = 0; n < ar->dimen; n++)
4523 newss = gfc_get_ss ();
4524 newss->type = GFC_SS_SCALAR;
4525 newss->expr = ar->start[n];
4532 newss = gfc_get_ss ();
4533 newss->type = GFC_SS_SECTION;
4536 newss->data.info.dimen = ar->as->rank;
4537 newss->data.info.ref = ref;
4539 /* Make sure array is the same as array(:,:), this way
4540 we don't need to special case all the time. */
4541 ar->dimen = ar->as->rank;
4542 for (n = 0; n < ar->dimen; n++)
4544 newss->data.info.dim[n] = n;
4545 ar->dimen_type[n] = DIMEN_RANGE;
4547 gcc_assert (ar->start[n] == NULL);
4548 gcc_assert (ar->end[n] == NULL);
4549 gcc_assert (ar->stride[n] == NULL);
4555 newss = gfc_get_ss ();
4556 newss->type = GFC_SS_SECTION;
4559 newss->data.info.dimen = 0;
4560 newss->data.info.ref = ref;
4564 /* We add SS chains for all the subscripts in the section. */
4565 for (n = 0; n < ar->dimen; n++)
4569 switch (ar->dimen_type[n])
4572 /* Add SS for elemental (scalar) subscripts. */
4573 gcc_assert (ar->start[n]);
4574 indexss = gfc_get_ss ();
4575 indexss->type = GFC_SS_SCALAR;
4576 indexss->expr = ar->start[n];
4577 indexss->next = gfc_ss_terminator;
4578 indexss->loop_chain = gfc_ss_terminator;
4579 newss->data.info.subscript[n] = indexss;
4583 /* We don't add anything for sections, just remember this
4584 dimension for later. */
4585 newss->data.info.dim[newss->data.info.dimen] = n;
4586 newss->data.info.dimen++;
4590 /* Create a GFC_SS_VECTOR index in which we can store
4591 the vector's descriptor. */
4592 indexss = gfc_get_ss ();
4593 indexss->type = GFC_SS_VECTOR;
4594 indexss->expr = ar->start[n];
4595 indexss->next = gfc_ss_terminator;
4596 indexss->loop_chain = gfc_ss_terminator;
4597 newss->data.info.subscript[n] = indexss;
4598 newss->data.info.dim[newss->data.info.dimen] = n;
4599 newss->data.info.dimen++;
4603 /* We should know what sort of section it is by now. */
4607 /* We should have at least one non-elemental dimension. */
4608 gcc_assert (newss->data.info.dimen > 0);
4613 /* We should know what sort of section it is by now. */
4622 /* Walk an expression operator. If only one operand of a binary expression is
4623 scalar, we must also add the scalar term to the SS chain. */
4626 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4632 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4633 if (expr->value.op.op2 == NULL)
4636 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
4638 /* All operands are scalar. Pass back and let the caller deal with it. */
4642 /* All operands require scalarization. */
4643 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
4646 /* One of the operands needs scalarization, the other is scalar.
4647 Create a gfc_ss for the scalar expression. */
4648 newss = gfc_get_ss ();
4649 newss->type = GFC_SS_SCALAR;
4652 /* First operand is scalar. We build the chain in reverse order, so
4653 add the scarar SS after the second operand. */
4655 while (head && head->next != ss)
4657 /* Check we haven't somehow broken the chain. */
4661 newss->expr = expr->value.op.op1;
4663 else /* head2 == head */
4665 gcc_assert (head2 == head);
4666 /* Second operand is scalar. */
4667 newss->next = head2;
4669 newss->expr = expr->value.op.op2;
4676 /* Reverse a SS chain. */
4679 gfc_reverse_ss (gfc_ss * ss)
4684 gcc_assert (ss != NULL);
4686 head = gfc_ss_terminator;
4687 while (ss != gfc_ss_terminator)
4690 /* Check we didn't somehow break the chain. */
4691 gcc_assert (next != NULL);
4701 /* Walk the arguments of an elemental function. */
4704 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
4712 head = gfc_ss_terminator;
4715 for (; arg; arg = arg->next)
4720 newss = gfc_walk_subexpr (head, arg->expr);
4723 /* Scalar argument. */
4724 newss = gfc_get_ss ();
4726 newss->expr = arg->expr;
4736 while (tail->next != gfc_ss_terminator)
4743 /* If all the arguments are scalar we don't need the argument SS. */
4744 gfc_free_ss_chain (head);
4749 /* Add it onto the existing chain. */
4755 /* Walk a function call. Scalar functions are passed back, and taken out of
4756 scalarization loops. For elemental functions we walk their arguments.
4757 The result of functions returning arrays is stored in a temporary outside
4758 the loop, so that the function is only called once. Hence we do not need
4759 to walk their arguments. */
4762 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4765 gfc_intrinsic_sym *isym;
4768 isym = expr->value.function.isym;
4770 /* Handle intrinsic functions separately. */
4772 return gfc_walk_intrinsic_function (ss, expr, isym);
4774 sym = expr->value.function.esym;
4776 sym = expr->symtree->n.sym;
4778 /* A function that returns arrays. */
4779 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4781 newss = gfc_get_ss ();
4782 newss->type = GFC_SS_FUNCTION;
4785 newss->data.info.dimen = expr->rank;
4789 /* Walk the parameters of an elemental function. For now we always pass
4791 if (sym->attr.elemental)
4792 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
4795 /* Scalar functions are OK as these are evaluated outside the scalarization
4796 loop. Pass back and let the caller deal with it. */
4801 /* An array temporary is constructed for array constructors. */
4804 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4809 newss = gfc_get_ss ();
4810 newss->type = GFC_SS_CONSTRUCTOR;
4813 newss->data.info.dimen = expr->rank;
4814 for (n = 0; n < expr->rank; n++)
4815 newss->data.info.dim[n] = n;
4821 /* Walk an expression. Add walked expressions to the head of the SS chain.
4822 A wholly scalar expression will not be added. */
4825 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4829 switch (expr->expr_type)
4832 head = gfc_walk_variable_expr (ss, expr);
4836 head = gfc_walk_op_expr (ss, expr);
4840 head = gfc_walk_function_expr (ss, expr);
4845 case EXPR_STRUCTURE:
4846 /* Pass back and let the caller deal with it. */
4850 head = gfc_walk_array_constructor (ss, expr);
4853 case EXPR_SUBSTRING:
4854 /* Pass back and let the caller deal with it. */
4858 internal_error ("bad expression type during walk (%d)",
4865 /* Entry point for expression walking.
4866 A return value equal to the passed chain means this is
4867 a scalar expression. It is up to the caller to take whatever action is
4868 necessary to translate these. */
4871 gfc_walk_expr (gfc_expr * expr)
4875 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4876 return gfc_reverse_ss (res);