2014-01-17 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / fortran / trans-array.c
blob0f5375dba950d8182ad848e18789d0f8c5ff11dc
1 /* Array translation routines
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
27 expressions.
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
53 term is calculated.
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
78 #include "config.h"
79 #include "system.h"
80 #include "coretypes.h"
81 #include "tree.h"
82 #include "gimple-expr.h"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
84 #include "flags.h"
85 #include "gfortran.h"
86 #include "constructor.h"
87 #include "trans.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
94 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var;
98 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
101 static tree
102 gfc_array_dataptr_type (tree desc)
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
124 Don't forget to #undef these! */
126 #define DATA_FIELD 0
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
130 #define CAF_TOKEN_FIELD 4
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
139 tree
140 gfc_conv_descriptor_data_get (tree desc)
142 tree field, type, t;
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
150 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 field, NULL_TREE);
152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
154 return t;
157 /* This provides WRITE access to the data field.
159 TUPLES_P is true if we are generating tuples.
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
165 void
166 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
168 tree field, type, t;
170 type = TREE_TYPE (desc);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
173 field = TYPE_FIELDS (type);
174 gcc_assert (DATA_FIELD == 0);
176 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
185 tree
186 gfc_conv_descriptor_data_addr (tree desc)
188 tree field, type, t;
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
196 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
197 field, NULL_TREE);
198 return gfc_build_addr_expr (NULL_TREE, t);
201 static tree
202 gfc_conv_descriptor_offset (tree desc)
204 tree type;
205 tree field;
207 type = TREE_TYPE (desc);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
213 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
214 desc, field, NULL_TREE);
217 tree
218 gfc_conv_descriptor_offset_get (tree desc)
220 return gfc_conv_descriptor_offset (desc);
223 void
224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
225 tree value)
227 tree t = gfc_conv_descriptor_offset (desc);
228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
232 tree
233 gfc_conv_descriptor_dtype (tree desc)
235 tree field;
236 tree type;
238 type = TREE_TYPE (desc);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
244 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
245 desc, field, NULL_TREE);
249 tree
250 gfc_conv_descriptor_rank (tree desc)
252 tree tmp;
253 tree dtype;
255 dtype = gfc_conv_descriptor_dtype (desc);
256 tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
257 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
258 dtype, tmp);
259 return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
263 tree
264 gfc_get_descriptor_dimension (tree desc)
266 tree type, field;
268 type = TREE_TYPE (desc);
269 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
271 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
272 gcc_assert (field != NULL_TREE
273 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
274 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
276 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
277 desc, field, NULL_TREE);
281 static tree
282 gfc_conv_descriptor_dimension (tree desc, tree dim)
284 tree tmp;
286 tmp = gfc_get_descriptor_dimension (desc);
288 return gfc_build_array_ref (tmp, dim, NULL);
292 tree
293 gfc_conv_descriptor_token (tree desc)
295 tree type;
296 tree field;
298 type = TREE_TYPE (desc);
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
300 gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
301 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
302 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
304 /* Should be a restricted pointer - except in the finalization wrapper. */
305 gcc_assert (field != NULL_TREE
306 && (TREE_TYPE (field) == prvoid_type_node
307 || TREE_TYPE (field) == pvoid_type_node));
309 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
310 desc, field, NULL_TREE);
314 static tree
315 gfc_conv_descriptor_stride (tree desc, tree dim)
317 tree tmp;
318 tree field;
320 tmp = gfc_conv_descriptor_dimension (desc, dim);
321 field = TYPE_FIELDS (TREE_TYPE (tmp));
322 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
323 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
325 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
326 tmp, field, NULL_TREE);
327 return tmp;
330 tree
331 gfc_conv_descriptor_stride_get (tree desc, tree dim)
333 tree type = TREE_TYPE (desc);
334 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
335 if (integer_zerop (dim)
336 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
337 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
338 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
339 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
340 return gfc_index_one_node;
342 return gfc_conv_descriptor_stride (desc, dim);
345 void
346 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
347 tree dim, tree value)
349 tree t = gfc_conv_descriptor_stride (desc, dim);
350 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
353 static tree
354 gfc_conv_descriptor_lbound (tree desc, tree dim)
356 tree tmp;
357 tree field;
359 tmp = gfc_conv_descriptor_dimension (desc, dim);
360 field = TYPE_FIELDS (TREE_TYPE (tmp));
361 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
362 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
364 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
365 tmp, field, NULL_TREE);
366 return tmp;
369 tree
370 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
372 return gfc_conv_descriptor_lbound (desc, dim);
375 void
376 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
377 tree dim, tree value)
379 tree t = gfc_conv_descriptor_lbound (desc, dim);
380 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
383 static tree
384 gfc_conv_descriptor_ubound (tree desc, tree dim)
386 tree tmp;
387 tree field;
389 tmp = gfc_conv_descriptor_dimension (desc, dim);
390 field = TYPE_FIELDS (TREE_TYPE (tmp));
391 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
392 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
394 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
395 tmp, field, NULL_TREE);
396 return tmp;
399 tree
400 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
402 return gfc_conv_descriptor_ubound (desc, dim);
405 void
406 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
407 tree dim, tree value)
409 tree t = gfc_conv_descriptor_ubound (desc, dim);
410 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
413 /* Build a null array descriptor constructor. */
415 tree
416 gfc_build_null_descriptor (tree type)
418 tree field;
419 tree tmp;
421 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
422 gcc_assert (DATA_FIELD == 0);
423 field = TYPE_FIELDS (type);
425 /* Set a NULL data pointer. */
426 tmp = build_constructor_single (type, field, null_pointer_node);
427 TREE_CONSTANT (tmp) = 1;
428 /* All other fields are ignored. */
430 return tmp;
434 /* Modify a descriptor such that the lbound of a given dimension is the value
435 specified. This also updates ubound and offset accordingly. */
437 void
438 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
439 int dim, tree new_lbound)
441 tree offs, ubound, lbound, stride;
442 tree diff, offs_diff;
444 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
446 offs = gfc_conv_descriptor_offset_get (desc);
447 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
448 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
449 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
451 /* Get difference (new - old) by which to shift stuff. */
452 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
453 new_lbound, lbound);
455 /* Shift ubound and offset accordingly. This has to be done before
456 updating the lbound, as they depend on the lbound expression! */
457 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
458 ubound, diff);
459 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
460 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
461 diff, stride);
462 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
463 offs, offs_diff);
464 gfc_conv_descriptor_offset_set (block, desc, offs);
466 /* Finally set lbound to value we want. */
467 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
471 /* Cleanup those #defines. */
473 #undef DATA_FIELD
474 #undef OFFSET_FIELD
475 #undef DTYPE_FIELD
476 #undef DIMENSION_FIELD
477 #undef CAF_TOKEN_FIELD
478 #undef STRIDE_SUBFIELD
479 #undef LBOUND_SUBFIELD
480 #undef UBOUND_SUBFIELD
483 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
484 flags & 1 = Main loop body.
485 flags & 2 = temp copy loop. */
487 void
488 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
490 for (; ss != gfc_ss_terminator; ss = ss->next)
491 ss->info->useflags = flags;
495 /* Free a gfc_ss chain. */
497 void
498 gfc_free_ss_chain (gfc_ss * ss)
500 gfc_ss *next;
502 while (ss != gfc_ss_terminator)
504 gcc_assert (ss != NULL);
505 next = ss->next;
506 gfc_free_ss (ss);
507 ss = next;
512 static void
513 free_ss_info (gfc_ss_info *ss_info)
515 int n;
517 ss_info->refcount--;
518 if (ss_info->refcount > 0)
519 return;
521 gcc_assert (ss_info->refcount == 0);
523 switch (ss_info->type)
525 case GFC_SS_SECTION:
526 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
527 if (ss_info->data.array.subscript[n])
528 gfc_free_ss_chain (ss_info->data.array.subscript[n]);
529 break;
531 default:
532 break;
535 free (ss_info);
539 /* Free a SS. */
541 void
542 gfc_free_ss (gfc_ss * ss)
544 free_ss_info (ss->info);
545 free (ss);
549 /* Creates and initializes an array type gfc_ss struct. */
551 gfc_ss *
552 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
554 gfc_ss *ss;
555 gfc_ss_info *ss_info;
556 int i;
558 ss_info = gfc_get_ss_info ();
559 ss_info->refcount++;
560 ss_info->type = type;
561 ss_info->expr = expr;
563 ss = gfc_get_ss ();
564 ss->info = ss_info;
565 ss->next = next;
566 ss->dimen = dimen;
567 for (i = 0; i < ss->dimen; i++)
568 ss->dim[i] = i;
570 return ss;
574 /* Creates and initializes a temporary type gfc_ss struct. */
576 gfc_ss *
577 gfc_get_temp_ss (tree type, tree string_length, int dimen)
579 gfc_ss *ss;
580 gfc_ss_info *ss_info;
581 int i;
583 ss_info = gfc_get_ss_info ();
584 ss_info->refcount++;
585 ss_info->type = GFC_SS_TEMP;
586 ss_info->string_length = string_length;
587 ss_info->data.temp.type = type;
589 ss = gfc_get_ss ();
590 ss->info = ss_info;
591 ss->next = gfc_ss_terminator;
592 ss->dimen = dimen;
593 for (i = 0; i < ss->dimen; i++)
594 ss->dim[i] = i;
596 return ss;
600 /* Creates and initializes a scalar type gfc_ss struct. */
602 gfc_ss *
603 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
605 gfc_ss *ss;
606 gfc_ss_info *ss_info;
608 ss_info = gfc_get_ss_info ();
609 ss_info->refcount++;
610 ss_info->type = GFC_SS_SCALAR;
611 ss_info->expr = expr;
613 ss = gfc_get_ss ();
614 ss->info = ss_info;
615 ss->next = next;
617 return ss;
621 /* Free all the SS associated with a loop. */
623 void
624 gfc_cleanup_loop (gfc_loopinfo * loop)
626 gfc_loopinfo *loop_next, **ploop;
627 gfc_ss *ss;
628 gfc_ss *next;
630 ss = loop->ss;
631 while (ss != gfc_ss_terminator)
633 gcc_assert (ss != NULL);
634 next = ss->loop_chain;
635 gfc_free_ss (ss);
636 ss = next;
639 /* Remove reference to self in the parent loop. */
640 if (loop->parent)
641 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
642 if (*ploop == loop)
644 *ploop = loop->next;
645 break;
648 /* Free non-freed nested loops. */
649 for (loop = loop->nested; loop; loop = loop_next)
651 loop_next = loop->next;
652 gfc_cleanup_loop (loop);
653 free (loop);
658 static void
659 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
661 int n;
663 for (; ss != gfc_ss_terminator; ss = ss->next)
665 ss->loop = loop;
667 if (ss->info->type == GFC_SS_SCALAR
668 || ss->info->type == GFC_SS_REFERENCE
669 || ss->info->type == GFC_SS_TEMP)
670 continue;
672 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
673 if (ss->info->data.array.subscript[n] != NULL)
674 set_ss_loop (ss->info->data.array.subscript[n], loop);
679 /* Associate a SS chain with a loop. */
681 void
682 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
684 gfc_ss *ss;
685 gfc_loopinfo *nested_loop;
687 if (head == gfc_ss_terminator)
688 return;
690 set_ss_loop (head, loop);
692 ss = head;
693 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
695 if (ss->nested_ss)
697 nested_loop = ss->nested_ss->loop;
699 /* More than one ss can belong to the same loop. Hence, we add the
700 loop to the chain only if it is different from the previously
701 added one, to avoid duplicate nested loops. */
702 if (nested_loop != loop->nested)
704 gcc_assert (nested_loop->parent == NULL);
705 nested_loop->parent = loop;
707 gcc_assert (nested_loop->next == NULL);
708 nested_loop->next = loop->nested;
709 loop->nested = nested_loop;
711 else
712 gcc_assert (nested_loop->parent == loop);
715 if (ss->next == gfc_ss_terminator)
716 ss->loop_chain = loop->ss;
717 else
718 ss->loop_chain = ss->next;
720 gcc_assert (ss == gfc_ss_terminator);
721 loop->ss = head;
725 /* Generate an initializer for a static pointer or allocatable array. */
727 void
728 gfc_trans_static_array_pointer (gfc_symbol * sym)
730 tree type;
732 gcc_assert (TREE_STATIC (sym->backend_decl));
733 /* Just zero the data member. */
734 type = TREE_TYPE (sym->backend_decl);
735 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
739 /* If the bounds of SE's loop have not yet been set, see if they can be
740 determined from array spec AS, which is the array spec of a called
741 function. MAPPING maps the callee's dummy arguments to the values
742 that the caller is passing. Add any initialization and finalization
743 code to SE. */
745 void
746 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
747 gfc_se * se, gfc_array_spec * as)
749 int n, dim, total_dim;
750 gfc_se tmpse;
751 gfc_ss *ss;
752 tree lower;
753 tree upper;
754 tree tmp;
756 total_dim = 0;
758 if (!as || as->type != AS_EXPLICIT)
759 return;
761 for (ss = se->ss; ss; ss = ss->parent)
763 total_dim += ss->loop->dimen;
764 for (n = 0; n < ss->loop->dimen; n++)
766 /* The bound is known, nothing to do. */
767 if (ss->loop->to[n] != NULL_TREE)
768 continue;
770 dim = ss->dim[n];
771 gcc_assert (dim < as->rank);
772 gcc_assert (ss->loop->dimen <= as->rank);
774 /* Evaluate the lower bound. */
775 gfc_init_se (&tmpse, NULL);
776 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
777 gfc_add_block_to_block (&se->pre, &tmpse.pre);
778 gfc_add_block_to_block (&se->post, &tmpse.post);
779 lower = fold_convert (gfc_array_index_type, tmpse.expr);
781 /* ...and the upper bound. */
782 gfc_init_se (&tmpse, NULL);
783 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
784 gfc_add_block_to_block (&se->pre, &tmpse.pre);
785 gfc_add_block_to_block (&se->post, &tmpse.post);
786 upper = fold_convert (gfc_array_index_type, tmpse.expr);
788 /* Set the upper bound of the loop to UPPER - LOWER. */
789 tmp = fold_build2_loc (input_location, MINUS_EXPR,
790 gfc_array_index_type, upper, lower);
791 tmp = gfc_evaluate_now (tmp, &se->pre);
792 ss->loop->to[n] = tmp;
796 gcc_assert (total_dim == as->rank);
800 /* Generate code to allocate an array temporary, or create a variable to
801 hold the data. If size is NULL, zero the descriptor so that the
802 callee will allocate the array. If DEALLOC is true, also generate code to
803 free the array afterwards.
805 If INITIAL is not NULL, it is packed using internal_pack and the result used
806 as data instead of allocating a fresh, unitialized area of memory.
808 Initialization code is added to PRE and finalization code to POST.
809 DYNAMIC is true if the caller may want to extend the array later
810 using realloc. This prevents us from putting the array on the stack. */
812 static void
813 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
814 gfc_array_info * info, tree size, tree nelem,
815 tree initial, bool dynamic, bool dealloc)
817 tree tmp;
818 tree desc;
819 bool onstack;
821 desc = info->descriptor;
822 info->offset = gfc_index_zero_node;
823 if (size == NULL_TREE || integer_zerop (size))
825 /* A callee allocated array. */
826 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
827 onstack = FALSE;
829 else
831 /* Allocate the temporary. */
832 onstack = !dynamic && initial == NULL_TREE
833 && (gfc_option.flag_stack_arrays
834 || gfc_can_put_var_on_stack (size));
836 if (onstack)
838 /* Make a temporary variable to hold the data. */
839 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
840 nelem, gfc_index_one_node);
841 tmp = gfc_evaluate_now (tmp, pre);
842 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
843 tmp);
844 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
845 tmp);
846 tmp = gfc_create_var (tmp, "A");
847 /* If we're here only because of -fstack-arrays we have to
848 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
849 if (!gfc_can_put_var_on_stack (size))
850 gfc_add_expr_to_block (pre,
851 fold_build1_loc (input_location,
852 DECL_EXPR, TREE_TYPE (tmp),
853 tmp));
854 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
855 gfc_conv_descriptor_data_set (pre, desc, tmp);
857 else
859 /* Allocate memory to hold the data or call internal_pack. */
860 if (initial == NULL_TREE)
862 tmp = gfc_call_malloc (pre, NULL, size);
863 tmp = gfc_evaluate_now (tmp, pre);
865 else
867 tree packed;
868 tree source_data;
869 tree was_packed;
870 stmtblock_t do_copying;
872 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
873 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
874 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
875 tmp = gfc_get_element_type (tmp);
876 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
877 packed = gfc_create_var (build_pointer_type (tmp), "data");
879 tmp = build_call_expr_loc (input_location,
880 gfor_fndecl_in_pack, 1, initial);
881 tmp = fold_convert (TREE_TYPE (packed), tmp);
882 gfc_add_modify (pre, packed, tmp);
884 tmp = build_fold_indirect_ref_loc (input_location,
885 initial);
886 source_data = gfc_conv_descriptor_data_get (tmp);
888 /* internal_pack may return source->data without any allocation
889 or copying if it is already packed. If that's the case, we
890 need to allocate and copy manually. */
892 gfc_start_block (&do_copying);
893 tmp = gfc_call_malloc (&do_copying, NULL, size);
894 tmp = fold_convert (TREE_TYPE (packed), tmp);
895 gfc_add_modify (&do_copying, packed, tmp);
896 tmp = gfc_build_memcpy_call (packed, source_data, size);
897 gfc_add_expr_to_block (&do_copying, tmp);
899 was_packed = fold_build2_loc (input_location, EQ_EXPR,
900 boolean_type_node, packed,
901 source_data);
902 tmp = gfc_finish_block (&do_copying);
903 tmp = build3_v (COND_EXPR, was_packed, tmp,
904 build_empty_stmt (input_location));
905 gfc_add_expr_to_block (pre, tmp);
907 tmp = fold_convert (pvoid_type_node, packed);
910 gfc_conv_descriptor_data_set (pre, desc, tmp);
913 info->data = gfc_conv_descriptor_data_get (desc);
915 /* The offset is zero because we create temporaries with a zero
916 lower bound. */
917 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
919 if (dealloc && !onstack)
921 /* Free the temporary. */
922 tmp = gfc_conv_descriptor_data_get (desc);
923 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
924 gfc_add_expr_to_block (post, tmp);
929 /* Get the scalarizer array dimension corresponding to actual array dimension
930 given by ARRAY_DIM.
932 For example, if SS represents the array ref a(1,:,:,1), it is a
933 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
934 and 1 for ARRAY_DIM=2.
935 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
936 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
937 ARRAY_DIM=3.
938 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
939 array. If called on the inner ss, the result would be respectively 0,1,2 for
940 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
941 for ARRAY_DIM=1,2. */
943 static int
944 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
946 int array_ref_dim;
947 int n;
949 array_ref_dim = 0;
951 for (; ss; ss = ss->parent)
952 for (n = 0; n < ss->dimen; n++)
953 if (ss->dim[n] < array_dim)
954 array_ref_dim++;
956 return array_ref_dim;
960 static gfc_ss *
961 innermost_ss (gfc_ss *ss)
963 while (ss->nested_ss != NULL)
964 ss = ss->nested_ss;
966 return ss;
971 /* Get the array reference dimension corresponding to the given loop dimension.
972 It is different from the true array dimension given by the dim array in
973 the case of a partial array reference (i.e. a(:,:,1,:) for example)
974 It is different from the loop dimension in the case of a transposed array.
977 static int
978 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
980 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
981 ss->dim[loop_dim]);
985 /* Generate code to create and initialize the descriptor for a temporary
986 array. This is used for both temporaries needed by the scalarizer, and
987 functions returning arrays. Adjusts the loop variables to be
988 zero-based, and calculates the loop bounds for callee allocated arrays.
989 Allocate the array unless it's callee allocated (we have a callee
990 allocated array if 'callee_alloc' is true, or if loop->to[n] is
991 NULL_TREE for any n). Also fills in the descriptor, data and offset
992 fields of info if known. Returns the size of the array, or NULL for a
993 callee allocated array.
995 'eltype' == NULL signals that the temporary should be a class object.
996 The 'initial' expression is used to obtain the size of the dynamic
997 type; otherwise the allocation and initialization proceeds as for any
998 other expression
1000 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1001 gfc_trans_allocate_array_storage. */
1003 tree
1004 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1005 tree eltype, tree initial, bool dynamic,
1006 bool dealloc, bool callee_alloc, locus * where)
1008 gfc_loopinfo *loop;
1009 gfc_ss *s;
1010 gfc_array_info *info;
1011 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1012 tree type;
1013 tree desc;
1014 tree tmp;
1015 tree size;
1016 tree nelem;
1017 tree cond;
1018 tree or_expr;
1019 tree class_expr = NULL_TREE;
1020 int n, dim, tmp_dim;
1021 int total_dim = 0;
1023 /* This signals a class array for which we need the size of the
1024 dynamic type. Generate an eltype and then the class expression. */
1025 if (eltype == NULL_TREE && initial)
1027 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1028 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1029 eltype = TREE_TYPE (class_expr);
1030 eltype = gfc_get_element_type (eltype);
1031 /* Obtain the structure (class) expression. */
1032 class_expr = TREE_OPERAND (class_expr, 0);
1033 gcc_assert (class_expr);
1036 memset (from, 0, sizeof (from));
1037 memset (to, 0, sizeof (to));
1039 info = &ss->info->data.array;
1041 gcc_assert (ss->dimen > 0);
1042 gcc_assert (ss->loop->dimen == ss->dimen);
1044 if (gfc_option.warn_array_temp && where)
1045 gfc_warning ("Creating array temporary at %L", where);
1047 /* Set the lower bound to zero. */
1048 for (s = ss; s; s = s->parent)
1050 loop = s->loop;
1052 total_dim += loop->dimen;
1053 for (n = 0; n < loop->dimen; n++)
1055 dim = s->dim[n];
1057 /* Callee allocated arrays may not have a known bound yet. */
1058 if (loop->to[n])
1059 loop->to[n] = gfc_evaluate_now (
1060 fold_build2_loc (input_location, MINUS_EXPR,
1061 gfc_array_index_type,
1062 loop->to[n], loop->from[n]),
1063 pre);
1064 loop->from[n] = gfc_index_zero_node;
1066 /* We have just changed the loop bounds, we must clear the
1067 corresponding specloop, so that delta calculation is not skipped
1068 later in gfc_set_delta. */
1069 loop->specloop[n] = NULL;
1071 /* We are constructing the temporary's descriptor based on the loop
1072 dimensions. As the dimensions may be accessed in arbitrary order
1073 (think of transpose) the size taken from the n'th loop may not map
1074 to the n'th dimension of the array. We need to reconstruct loop
1075 infos in the right order before using it to set the descriptor
1076 bounds. */
1077 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1078 from[tmp_dim] = loop->from[n];
1079 to[tmp_dim] = loop->to[n];
1081 info->delta[dim] = gfc_index_zero_node;
1082 info->start[dim] = gfc_index_zero_node;
1083 info->end[dim] = gfc_index_zero_node;
1084 info->stride[dim] = gfc_index_one_node;
1088 /* Initialize the descriptor. */
1089 type =
1090 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1091 GFC_ARRAY_UNKNOWN, true);
1092 desc = gfc_create_var (type, "atmp");
1093 GFC_DECL_PACKED_ARRAY (desc) = 1;
1095 info->descriptor = desc;
1096 size = gfc_index_one_node;
1098 /* Fill in the array dtype. */
1099 tmp = gfc_conv_descriptor_dtype (desc);
1100 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1103 Fill in the bounds and stride. This is a packed array, so:
1105 size = 1;
1106 for (n = 0; n < rank; n++)
1108 stride[n] = size
1109 delta = ubound[n] + 1 - lbound[n];
1110 size = size * delta;
1112 size = size * sizeof(element);
1115 or_expr = NULL_TREE;
1117 /* If there is at least one null loop->to[n], it is a callee allocated
1118 array. */
1119 for (n = 0; n < total_dim; n++)
1120 if (to[n] == NULL_TREE)
1122 size = NULL_TREE;
1123 break;
1126 if (size == NULL_TREE)
1127 for (s = ss; s; s = s->parent)
1128 for (n = 0; n < s->loop->dimen; n++)
1130 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1132 /* For a callee allocated array express the loop bounds in terms
1133 of the descriptor fields. */
1134 tmp = fold_build2_loc (input_location,
1135 MINUS_EXPR, gfc_array_index_type,
1136 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1137 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1138 s->loop->to[n] = tmp;
1140 else
1142 for (n = 0; n < total_dim; n++)
1144 /* Store the stride and bound components in the descriptor. */
1145 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1147 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1148 gfc_index_zero_node);
1150 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1152 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1153 gfc_array_index_type,
1154 to[n], gfc_index_one_node);
1156 /* Check whether the size for this dimension is negative. */
1157 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1158 tmp, gfc_index_zero_node);
1159 cond = gfc_evaluate_now (cond, pre);
1161 if (n == 0)
1162 or_expr = cond;
1163 else
1164 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1165 boolean_type_node, or_expr, cond);
1167 size = fold_build2_loc (input_location, MULT_EXPR,
1168 gfc_array_index_type, size, tmp);
1169 size = gfc_evaluate_now (size, pre);
1173 /* Get the size of the array. */
1174 if (size && !callee_alloc)
1176 tree elemsize;
1177 /* If or_expr is true, then the extent in at least one
1178 dimension is zero and the size is set to zero. */
1179 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1180 or_expr, gfc_index_zero_node, size);
1182 nelem = size;
1183 if (class_expr == NULL_TREE)
1184 elemsize = fold_convert (gfc_array_index_type,
1185 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1186 else
1187 elemsize = gfc_vtable_size_get (class_expr);
1189 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1190 size, elemsize);
1192 else
1194 nelem = size;
1195 size = NULL_TREE;
1198 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1199 dynamic, dealloc);
1201 while (ss->parent)
1202 ss = ss->parent;
1204 if (ss->dimen > ss->loop->temp_dim)
1205 ss->loop->temp_dim = ss->dimen;
1207 return size;
1211 /* Return the number of iterations in a loop that starts at START,
1212 ends at END, and has step STEP. */
1214 static tree
1215 gfc_get_iteration_count (tree start, tree end, tree step)
1217 tree tmp;
1218 tree type;
1220 type = TREE_TYPE (step);
1221 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1222 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1223 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1224 build_int_cst (type, 1));
1225 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1226 build_int_cst (type, 0));
1227 return fold_convert (gfc_array_index_type, tmp);
1231 /* Extend the data in array DESC by EXTRA elements. */
1233 static void
1234 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1236 tree arg0, arg1;
1237 tree tmp;
1238 tree size;
1239 tree ubound;
1241 if (integer_zerop (extra))
1242 return;
1244 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1246 /* Add EXTRA to the upper bound. */
1247 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1248 ubound, extra);
1249 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1251 /* Get the value of the current data pointer. */
1252 arg0 = gfc_conv_descriptor_data_get (desc);
1254 /* Calculate the new array size. */
1255 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1256 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1257 ubound, gfc_index_one_node);
1258 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1259 fold_convert (size_type_node, tmp),
1260 fold_convert (size_type_node, size));
1262 /* Call the realloc() function. */
1263 tmp = gfc_call_realloc (pblock, arg0, arg1);
1264 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1268 /* Return true if the bounds of iterator I can only be determined
1269 at run time. */
1271 static inline bool
1272 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1274 return (i->start->expr_type != EXPR_CONSTANT
1275 || i->end->expr_type != EXPR_CONSTANT
1276 || i->step->expr_type != EXPR_CONSTANT);
1280 /* Split the size of constructor element EXPR into the sum of two terms,
1281 one of which can be determined at compile time and one of which must
1282 be calculated at run time. Set *SIZE to the former and return true
1283 if the latter might be nonzero. */
1285 static bool
1286 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1288 if (expr->expr_type == EXPR_ARRAY)
1289 return gfc_get_array_constructor_size (size, expr->value.constructor);
1290 else if (expr->rank > 0)
1292 /* Calculate everything at run time. */
1293 mpz_set_ui (*size, 0);
1294 return true;
1296 else
1298 /* A single element. */
1299 mpz_set_ui (*size, 1);
1300 return false;
1305 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1306 of array constructor C. */
1308 static bool
1309 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1311 gfc_constructor *c;
1312 gfc_iterator *i;
1313 mpz_t val;
1314 mpz_t len;
1315 bool dynamic;
1317 mpz_set_ui (*size, 0);
1318 mpz_init (len);
1319 mpz_init (val);
1321 dynamic = false;
1322 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1324 i = c->iterator;
1325 if (i && gfc_iterator_has_dynamic_bounds (i))
1326 dynamic = true;
1327 else
1329 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1330 if (i)
1332 /* Multiply the static part of the element size by the
1333 number of iterations. */
1334 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1335 mpz_fdiv_q (val, val, i->step->value.integer);
1336 mpz_add_ui (val, val, 1);
1337 if (mpz_sgn (val) > 0)
1338 mpz_mul (len, len, val);
1339 else
1340 mpz_set_ui (len, 0);
1342 mpz_add (*size, *size, len);
1345 mpz_clear (len);
1346 mpz_clear (val);
1347 return dynamic;
1351 /* Make sure offset is a variable. */
1353 static void
1354 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1355 tree * offsetvar)
1357 /* We should have already created the offset variable. We cannot
1358 create it here because we may be in an inner scope. */
1359 gcc_assert (*offsetvar != NULL_TREE);
1360 gfc_add_modify (pblock, *offsetvar, *poffset);
1361 *poffset = *offsetvar;
1362 TREE_USED (*offsetvar) = 1;
1366 /* Variables needed for bounds-checking. */
1367 static bool first_len;
1368 static tree first_len_val;
1369 static bool typespec_chararray_ctor;
1371 static void
1372 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1373 tree offset, gfc_se * se, gfc_expr * expr)
1375 tree tmp;
1377 gfc_conv_expr (se, expr);
1379 /* Store the value. */
1380 tmp = build_fold_indirect_ref_loc (input_location,
1381 gfc_conv_descriptor_data_get (desc));
1382 tmp = gfc_build_array_ref (tmp, offset, NULL);
1384 if (expr->ts.type == BT_CHARACTER)
1386 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1387 tree esize;
1389 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1390 esize = fold_convert (gfc_charlen_type_node, esize);
1391 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1392 gfc_charlen_type_node, esize,
1393 build_int_cst (gfc_charlen_type_node,
1394 gfc_character_kinds[i].bit_size / 8));
1396 gfc_conv_string_parameter (se);
1397 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1399 /* The temporary is an array of pointers. */
1400 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1401 gfc_add_modify (&se->pre, tmp, se->expr);
1403 else
1405 /* The temporary is an array of string values. */
1406 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1407 /* We know the temporary and the value will be the same length,
1408 so can use memcpy. */
1409 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1410 se->string_length, se->expr, expr->ts.kind);
1412 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1414 if (first_len)
1416 gfc_add_modify (&se->pre, first_len_val,
1417 se->string_length);
1418 first_len = false;
1420 else
1422 /* Verify that all constructor elements are of the same
1423 length. */
1424 tree cond = fold_build2_loc (input_location, NE_EXPR,
1425 boolean_type_node, first_len_val,
1426 se->string_length);
1427 gfc_trans_runtime_check
1428 (true, false, cond, &se->pre, &expr->where,
1429 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1430 fold_convert (long_integer_type_node, first_len_val),
1431 fold_convert (long_integer_type_node, se->string_length));
1435 else
1437 /* TODO: Should the frontend already have done this conversion? */
1438 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1439 gfc_add_modify (&se->pre, tmp, se->expr);
1442 gfc_add_block_to_block (pblock, &se->pre);
1443 gfc_add_block_to_block (pblock, &se->post);
1447 /* Add the contents of an array to the constructor. DYNAMIC is as for
1448 gfc_trans_array_constructor_value. */
1450 static void
1451 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1452 tree type ATTRIBUTE_UNUSED,
1453 tree desc, gfc_expr * expr,
1454 tree * poffset, tree * offsetvar,
1455 bool dynamic)
1457 gfc_se se;
1458 gfc_ss *ss;
1459 gfc_loopinfo loop;
1460 stmtblock_t body;
1461 tree tmp;
1462 tree size;
1463 int n;
1465 /* We need this to be a variable so we can increment it. */
1466 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1468 gfc_init_se (&se, NULL);
1470 /* Walk the array expression. */
1471 ss = gfc_walk_expr (expr);
1472 gcc_assert (ss != gfc_ss_terminator);
1474 /* Initialize the scalarizer. */
1475 gfc_init_loopinfo (&loop);
1476 gfc_add_ss_to_loop (&loop, ss);
1478 /* Initialize the loop. */
1479 gfc_conv_ss_startstride (&loop);
1480 gfc_conv_loop_setup (&loop, &expr->where);
1482 /* Make sure the constructed array has room for the new data. */
1483 if (dynamic)
1485 /* Set SIZE to the total number of elements in the subarray. */
1486 size = gfc_index_one_node;
1487 for (n = 0; n < loop.dimen; n++)
1489 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1490 gfc_index_one_node);
1491 size = fold_build2_loc (input_location, MULT_EXPR,
1492 gfc_array_index_type, size, tmp);
1495 /* Grow the constructed array by SIZE elements. */
1496 gfc_grow_array (&loop.pre, desc, size);
1499 /* Make the loop body. */
1500 gfc_mark_ss_chain_used (ss, 1);
1501 gfc_start_scalarized_body (&loop, &body);
1502 gfc_copy_loopinfo_to_se (&se, &loop);
1503 se.ss = ss;
1505 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1506 gcc_assert (se.ss == gfc_ss_terminator);
1508 /* Increment the offset. */
1509 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1510 *poffset, gfc_index_one_node);
1511 gfc_add_modify (&body, *poffset, tmp);
1513 /* Finish the loop. */
1514 gfc_trans_scalarizing_loops (&loop, &body);
1515 gfc_add_block_to_block (&loop.pre, &loop.post);
1516 tmp = gfc_finish_block (&loop.pre);
1517 gfc_add_expr_to_block (pblock, tmp);
1519 gfc_cleanup_loop (&loop);
1523 /* Assign the values to the elements of an array constructor. DYNAMIC
1524 is true if descriptor DESC only contains enough data for the static
1525 size calculated by gfc_get_array_constructor_size. When true, memory
1526 for the dynamic parts must be allocated using realloc. */
1528 static void
1529 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1530 tree desc, gfc_constructor_base base,
1531 tree * poffset, tree * offsetvar,
1532 bool dynamic)
1534 tree tmp;
1535 tree start = NULL_TREE;
1536 tree end = NULL_TREE;
1537 tree step = NULL_TREE;
1538 stmtblock_t body;
1539 gfc_se se;
1540 mpz_t size;
1541 gfc_constructor *c;
1543 tree shadow_loopvar = NULL_TREE;
1544 gfc_saved_var saved_loopvar;
1546 mpz_init (size);
1547 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1549 /* If this is an iterator or an array, the offset must be a variable. */
1550 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1551 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1553 /* Shadowing the iterator avoids changing its value and saves us from
1554 keeping track of it. Further, it makes sure that there's always a
1555 backend-decl for the symbol, even if there wasn't one before,
1556 e.g. in the case of an iterator that appears in a specification
1557 expression in an interface mapping. */
1558 if (c->iterator)
1560 gfc_symbol *sym;
1561 tree type;
1563 /* Evaluate loop bounds before substituting the loop variable
1564 in case they depend on it. Such a case is invalid, but it is
1565 not more expensive to do the right thing here.
1566 See PR 44354. */
1567 gfc_init_se (&se, NULL);
1568 gfc_conv_expr_val (&se, c->iterator->start);
1569 gfc_add_block_to_block (pblock, &se.pre);
1570 start = gfc_evaluate_now (se.expr, pblock);
1572 gfc_init_se (&se, NULL);
1573 gfc_conv_expr_val (&se, c->iterator->end);
1574 gfc_add_block_to_block (pblock, &se.pre);
1575 end = gfc_evaluate_now (se.expr, pblock);
1577 gfc_init_se (&se, NULL);
1578 gfc_conv_expr_val (&se, c->iterator->step);
1579 gfc_add_block_to_block (pblock, &se.pre);
1580 step = gfc_evaluate_now (se.expr, pblock);
1582 sym = c->iterator->var->symtree->n.sym;
1583 type = gfc_typenode_for_spec (&sym->ts);
1585 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1586 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1589 gfc_start_block (&body);
1591 if (c->expr->expr_type == EXPR_ARRAY)
1593 /* Array constructors can be nested. */
1594 gfc_trans_array_constructor_value (&body, type, desc,
1595 c->expr->value.constructor,
1596 poffset, offsetvar, dynamic);
1598 else if (c->expr->rank > 0)
1600 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1601 poffset, offsetvar, dynamic);
1603 else
1605 /* This code really upsets the gimplifier so don't bother for now. */
1606 gfc_constructor *p;
1607 HOST_WIDE_INT n;
1608 HOST_WIDE_INT size;
1610 p = c;
1611 n = 0;
1612 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1614 p = gfc_constructor_next (p);
1615 n++;
1617 if (n < 4)
1619 /* Scalar values. */
1620 gfc_init_se (&se, NULL);
1621 gfc_trans_array_ctor_element (&body, desc, *poffset,
1622 &se, c->expr);
1624 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1625 gfc_array_index_type,
1626 *poffset, gfc_index_one_node);
1628 else
1630 /* Collect multiple scalar constants into a constructor. */
1631 vec<constructor_elt, va_gc> *v = NULL;
1632 tree init;
1633 tree bound;
1634 tree tmptype;
1635 HOST_WIDE_INT idx = 0;
1637 p = c;
1638 /* Count the number of consecutive scalar constants. */
1639 while (p && !(p->iterator
1640 || p->expr->expr_type != EXPR_CONSTANT))
1642 gfc_init_se (&se, NULL);
1643 gfc_conv_constant (&se, p->expr);
1645 if (c->expr->ts.type != BT_CHARACTER)
1646 se.expr = fold_convert (type, se.expr);
1647 /* For constant character array constructors we build
1648 an array of pointers. */
1649 else if (POINTER_TYPE_P (type))
1650 se.expr = gfc_build_addr_expr
1651 (gfc_get_pchar_type (p->expr->ts.kind),
1652 se.expr);
1654 CONSTRUCTOR_APPEND_ELT (v,
1655 build_int_cst (gfc_array_index_type,
1656 idx++),
1657 se.expr);
1658 c = p;
1659 p = gfc_constructor_next (p);
1662 bound = size_int (n - 1);
1663 /* Create an array type to hold them. */
1664 tmptype = build_range_type (gfc_array_index_type,
1665 gfc_index_zero_node, bound);
1666 tmptype = build_array_type (type, tmptype);
1668 init = build_constructor (tmptype, v);
1669 TREE_CONSTANT (init) = 1;
1670 TREE_STATIC (init) = 1;
1671 /* Create a static variable to hold the data. */
1672 tmp = gfc_create_var (tmptype, "data");
1673 TREE_STATIC (tmp) = 1;
1674 TREE_CONSTANT (tmp) = 1;
1675 TREE_READONLY (tmp) = 1;
1676 DECL_INITIAL (tmp) = init;
1677 init = tmp;
1679 /* Use BUILTIN_MEMCPY to assign the values. */
1680 tmp = gfc_conv_descriptor_data_get (desc);
1681 tmp = build_fold_indirect_ref_loc (input_location,
1682 tmp);
1683 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1684 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1685 init = gfc_build_addr_expr (NULL_TREE, init);
1687 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1688 bound = build_int_cst (size_type_node, n * size);
1689 tmp = build_call_expr_loc (input_location,
1690 builtin_decl_explicit (BUILT_IN_MEMCPY),
1691 3, tmp, init, bound);
1692 gfc_add_expr_to_block (&body, tmp);
1694 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1695 gfc_array_index_type, *poffset,
1696 build_int_cst (gfc_array_index_type, n));
1698 if (!INTEGER_CST_P (*poffset))
1700 gfc_add_modify (&body, *offsetvar, *poffset);
1701 *poffset = *offsetvar;
1705 /* The frontend should already have done any expansions
1706 at compile-time. */
1707 if (!c->iterator)
1709 /* Pass the code as is. */
1710 tmp = gfc_finish_block (&body);
1711 gfc_add_expr_to_block (pblock, tmp);
1713 else
1715 /* Build the implied do-loop. */
1716 stmtblock_t implied_do_block;
1717 tree cond;
1718 tree exit_label;
1719 tree loopbody;
1720 tree tmp2;
1722 loopbody = gfc_finish_block (&body);
1724 /* Create a new block that holds the implied-do loop. A temporary
1725 loop-variable is used. */
1726 gfc_start_block(&implied_do_block);
1728 /* Initialize the loop. */
1729 gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1731 /* If this array expands dynamically, and the number of iterations
1732 is not constant, we won't have allocated space for the static
1733 part of C->EXPR's size. Do that now. */
1734 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1736 /* Get the number of iterations. */
1737 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1739 /* Get the static part of C->EXPR's size. */
1740 gfc_get_array_constructor_element_size (&size, c->expr);
1741 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1743 /* Grow the array by TMP * TMP2 elements. */
1744 tmp = fold_build2_loc (input_location, MULT_EXPR,
1745 gfc_array_index_type, tmp, tmp2);
1746 gfc_grow_array (&implied_do_block, desc, tmp);
1749 /* Generate the loop body. */
1750 exit_label = gfc_build_label_decl (NULL_TREE);
1751 gfc_start_block (&body);
1753 /* Generate the exit condition. Depending on the sign of
1754 the step variable we have to generate the correct
1755 comparison. */
1756 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1757 step, build_int_cst (TREE_TYPE (step), 0));
1758 cond = fold_build3_loc (input_location, COND_EXPR,
1759 boolean_type_node, tmp,
1760 fold_build2_loc (input_location, GT_EXPR,
1761 boolean_type_node, shadow_loopvar, end),
1762 fold_build2_loc (input_location, LT_EXPR,
1763 boolean_type_node, shadow_loopvar, end));
1764 tmp = build1_v (GOTO_EXPR, exit_label);
1765 TREE_USED (exit_label) = 1;
1766 tmp = build3_v (COND_EXPR, cond, tmp,
1767 build_empty_stmt (input_location));
1768 gfc_add_expr_to_block (&body, tmp);
1770 /* The main loop body. */
1771 gfc_add_expr_to_block (&body, loopbody);
1773 /* Increase loop variable by step. */
1774 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1775 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1776 step);
1777 gfc_add_modify (&body, shadow_loopvar, tmp);
1779 /* Finish the loop. */
1780 tmp = gfc_finish_block (&body);
1781 tmp = build1_v (LOOP_EXPR, tmp);
1782 gfc_add_expr_to_block (&implied_do_block, tmp);
1784 /* Add the exit label. */
1785 tmp = build1_v (LABEL_EXPR, exit_label);
1786 gfc_add_expr_to_block (&implied_do_block, tmp);
1788 /* Finish the implied-do loop. */
1789 tmp = gfc_finish_block(&implied_do_block);
1790 gfc_add_expr_to_block(pblock, tmp);
1792 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1795 mpz_clear (size);
1799 /* A catch-all to obtain the string length for anything that is not
1800 a substring of non-constant length, a constant, array or variable. */
1802 static void
1803 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1805 gfc_se se;
1807 /* Don't bother if we already know the length is a constant. */
1808 if (*len && INTEGER_CST_P (*len))
1809 return;
1811 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1812 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1814 /* This is easy. */
1815 gfc_conv_const_charlen (e->ts.u.cl);
1816 *len = e->ts.u.cl->backend_decl;
1818 else
1820 /* Otherwise, be brutal even if inefficient. */
1821 gfc_init_se (&se, NULL);
1823 /* No function call, in case of side effects. */
1824 se.no_function_call = 1;
1825 if (e->rank == 0)
1826 gfc_conv_expr (&se, e);
1827 else
1828 gfc_conv_expr_descriptor (&se, e);
1830 /* Fix the value. */
1831 *len = gfc_evaluate_now (se.string_length, &se.pre);
1833 gfc_add_block_to_block (block, &se.pre);
1834 gfc_add_block_to_block (block, &se.post);
1836 e->ts.u.cl->backend_decl = *len;
1841 /* Figure out the string length of a variable reference expression.
1842 Used by get_array_ctor_strlen. */
1844 static void
1845 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1847 gfc_ref *ref;
1848 gfc_typespec *ts;
1849 mpz_t char_len;
1851 /* Don't bother if we already know the length is a constant. */
1852 if (*len && INTEGER_CST_P (*len))
1853 return;
1855 ts = &expr->symtree->n.sym->ts;
1856 for (ref = expr->ref; ref; ref = ref->next)
1858 switch (ref->type)
1860 case REF_ARRAY:
1861 /* Array references don't change the string length. */
1862 break;
1864 case REF_COMPONENT:
1865 /* Use the length of the component. */
1866 ts = &ref->u.c.component->ts;
1867 break;
1869 case REF_SUBSTRING:
1870 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1871 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1873 /* Note that this might evaluate expr. */
1874 get_array_ctor_all_strlen (block, expr, len);
1875 return;
1877 mpz_init_set_ui (char_len, 1);
1878 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1879 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1880 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1881 *len = convert (gfc_charlen_type_node, *len);
1882 mpz_clear (char_len);
1883 return;
1885 default:
1886 gcc_unreachable ();
1890 *len = ts->u.cl->backend_decl;
1894 /* Figure out the string length of a character array constructor.
1895 If len is NULL, don't calculate the length; this happens for recursive calls
1896 when a sub-array-constructor is an element but not at the first position,
1897 so when we're not interested in the length.
1898 Returns TRUE if all elements are character constants. */
1900 bool
1901 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1903 gfc_constructor *c;
1904 bool is_const;
1906 is_const = TRUE;
1908 if (gfc_constructor_first (base) == NULL)
1910 if (len)
1911 *len = build_int_cstu (gfc_charlen_type_node, 0);
1912 return is_const;
1915 /* Loop over all constructor elements to find out is_const, but in len we
1916 want to store the length of the first, not the last, element. We can
1917 of course exit the loop as soon as is_const is found to be false. */
1918 for (c = gfc_constructor_first (base);
1919 c && is_const; c = gfc_constructor_next (c))
1921 switch (c->expr->expr_type)
1923 case EXPR_CONSTANT:
1924 if (len && !(*len && INTEGER_CST_P (*len)))
1925 *len = build_int_cstu (gfc_charlen_type_node,
1926 c->expr->value.character.length);
1927 break;
1929 case EXPR_ARRAY:
1930 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1931 is_const = false;
1932 break;
1934 case EXPR_VARIABLE:
1935 is_const = false;
1936 if (len)
1937 get_array_ctor_var_strlen (block, c->expr, len);
1938 break;
1940 default:
1941 is_const = false;
1942 if (len)
1943 get_array_ctor_all_strlen (block, c->expr, len);
1944 break;
1947 /* After the first iteration, we don't want the length modified. */
1948 len = NULL;
1951 return is_const;
1954 /* Check whether the array constructor C consists entirely of constant
1955 elements, and if so returns the number of those elements, otherwise
1956 return zero. Note, an empty or NULL array constructor returns zero. */
1958 unsigned HOST_WIDE_INT
1959 gfc_constant_array_constructor_p (gfc_constructor_base base)
1961 unsigned HOST_WIDE_INT nelem = 0;
1963 gfc_constructor *c = gfc_constructor_first (base);
1964 while (c)
1966 if (c->iterator
1967 || c->expr->rank > 0
1968 || c->expr->expr_type != EXPR_CONSTANT)
1969 return 0;
1970 c = gfc_constructor_next (c);
1971 nelem++;
1973 return nelem;
1977 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1978 and the tree type of it's elements, TYPE, return a static constant
1979 variable that is compile-time initialized. */
1981 tree
1982 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1984 tree tmptype, init, tmp;
1985 HOST_WIDE_INT nelem;
1986 gfc_constructor *c;
1987 gfc_array_spec as;
1988 gfc_se se;
1989 int i;
1990 vec<constructor_elt, va_gc> *v = NULL;
1992 /* First traverse the constructor list, converting the constants
1993 to tree to build an initializer. */
1994 nelem = 0;
1995 c = gfc_constructor_first (expr->value.constructor);
1996 while (c)
1998 gfc_init_se (&se, NULL);
1999 gfc_conv_constant (&se, c->expr);
2000 if (c->expr->ts.type != BT_CHARACTER)
2001 se.expr = fold_convert (type, se.expr);
2002 else if (POINTER_TYPE_P (type))
2003 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2004 se.expr);
2005 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2006 se.expr);
2007 c = gfc_constructor_next (c);
2008 nelem++;
2011 /* Next determine the tree type for the array. We use the gfortran
2012 front-end's gfc_get_nodesc_array_type in order to create a suitable
2013 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2015 memset (&as, 0, sizeof (gfc_array_spec));
2017 as.rank = expr->rank;
2018 as.type = AS_EXPLICIT;
2019 if (!expr->shape)
2021 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2022 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2023 NULL, nelem - 1);
2025 else
2026 for (i = 0; i < expr->rank; i++)
2028 int tmp = (int) mpz_get_si (expr->shape[i]);
2029 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2030 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2031 NULL, tmp - 1);
2034 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2036 /* as is not needed anymore. */
2037 for (i = 0; i < as.rank + as.corank; i++)
2039 gfc_free_expr (as.lower[i]);
2040 gfc_free_expr (as.upper[i]);
2043 init = build_constructor (tmptype, v);
2045 TREE_CONSTANT (init) = 1;
2046 TREE_STATIC (init) = 1;
2048 tmp = gfc_create_var (tmptype, "A");
2049 TREE_STATIC (tmp) = 1;
2050 TREE_CONSTANT (tmp) = 1;
2051 TREE_READONLY (tmp) = 1;
2052 DECL_INITIAL (tmp) = init;
2054 return tmp;
2058 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2059 This mostly initializes the scalarizer state info structure with the
2060 appropriate values to directly use the array created by the function
2061 gfc_build_constant_array_constructor. */
2063 static void
2064 trans_constant_array_constructor (gfc_ss * ss, tree type)
2066 gfc_array_info *info;
2067 tree tmp;
2068 int i;
2070 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2072 info = &ss->info->data.array;
2074 info->descriptor = tmp;
2075 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2076 info->offset = gfc_index_zero_node;
2078 for (i = 0; i < ss->dimen; i++)
2080 info->delta[i] = gfc_index_zero_node;
2081 info->start[i] = gfc_index_zero_node;
2082 info->end[i] = gfc_index_zero_node;
2083 info->stride[i] = gfc_index_one_node;
2088 static int
2089 get_rank (gfc_loopinfo *loop)
2091 int rank;
2093 rank = 0;
2094 for (; loop; loop = loop->parent)
2095 rank += loop->dimen;
2097 return rank;
2101 /* Helper routine of gfc_trans_array_constructor to determine if the
2102 bounds of the loop specified by LOOP are constant and simple enough
2103 to use with trans_constant_array_constructor. Returns the
2104 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2106 static tree
2107 constant_array_constructor_loop_size (gfc_loopinfo * l)
2109 gfc_loopinfo *loop;
2110 tree size = gfc_index_one_node;
2111 tree tmp;
2112 int i, total_dim;
2114 total_dim = get_rank (l);
2116 for (loop = l; loop; loop = loop->parent)
2118 for (i = 0; i < loop->dimen; i++)
2120 /* If the bounds aren't constant, return NULL_TREE. */
2121 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2122 return NULL_TREE;
2123 if (!integer_zerop (loop->from[i]))
2125 /* Only allow nonzero "from" in one-dimensional arrays. */
2126 if (total_dim != 1)
2127 return NULL_TREE;
2128 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2129 gfc_array_index_type,
2130 loop->to[i], loop->from[i]);
2132 else
2133 tmp = loop->to[i];
2134 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2135 gfc_array_index_type, tmp, gfc_index_one_node);
2136 size = fold_build2_loc (input_location, MULT_EXPR,
2137 gfc_array_index_type, size, tmp);
2141 return size;
2145 static tree *
2146 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2148 gfc_ss *ss;
2149 int n;
2151 gcc_assert (array->nested_ss == NULL);
2153 for (ss = array; ss; ss = ss->parent)
2154 for (n = 0; n < ss->loop->dimen; n++)
2155 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2156 return &(ss->loop->to[n]);
2158 gcc_unreachable ();
2162 static gfc_loopinfo *
2163 outermost_loop (gfc_loopinfo * loop)
2165 while (loop->parent != NULL)
2166 loop = loop->parent;
2168 return loop;
2172 /* Array constructors are handled by constructing a temporary, then using that
2173 within the scalarization loop. This is not optimal, but seems by far the
2174 simplest method. */
2176 static void
2177 trans_array_constructor (gfc_ss * ss, locus * where)
2179 gfc_constructor_base c;
2180 tree offset;
2181 tree offsetvar;
2182 tree desc;
2183 tree type;
2184 tree tmp;
2185 tree *loop_ubound0;
2186 bool dynamic;
2187 bool old_first_len, old_typespec_chararray_ctor;
2188 tree old_first_len_val;
2189 gfc_loopinfo *loop, *outer_loop;
2190 gfc_ss_info *ss_info;
2191 gfc_expr *expr;
2192 gfc_ss *s;
2194 /* Save the old values for nested checking. */
2195 old_first_len = first_len;
2196 old_first_len_val = first_len_val;
2197 old_typespec_chararray_ctor = typespec_chararray_ctor;
2199 loop = ss->loop;
2200 outer_loop = outermost_loop (loop);
2201 ss_info = ss->info;
2202 expr = ss_info->expr;
2204 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2205 typespec was given for the array constructor. */
2206 typespec_chararray_ctor = (expr->ts.u.cl
2207 && expr->ts.u.cl->length_from_typespec);
2209 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2210 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2212 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2213 first_len = true;
2216 gcc_assert (ss->dimen == ss->loop->dimen);
2218 c = expr->value.constructor;
2219 if (expr->ts.type == BT_CHARACTER)
2221 bool const_string;
2223 /* get_array_ctor_strlen walks the elements of the constructor, if a
2224 typespec was given, we already know the string length and want the one
2225 specified there. */
2226 if (typespec_chararray_ctor && expr->ts.u.cl->length
2227 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2229 gfc_se length_se;
2231 const_string = false;
2232 gfc_init_se (&length_se, NULL);
2233 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2234 gfc_charlen_type_node);
2235 ss_info->string_length = length_se.expr;
2236 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2237 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2239 else
2240 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2241 &ss_info->string_length);
2243 /* Complex character array constructors should have been taken care of
2244 and not end up here. */
2245 gcc_assert (ss_info->string_length);
2247 expr->ts.u.cl->backend_decl = ss_info->string_length;
2249 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2250 if (const_string)
2251 type = build_pointer_type (type);
2253 else
2254 type = gfc_typenode_for_spec (&expr->ts);
2256 /* See if the constructor determines the loop bounds. */
2257 dynamic = false;
2259 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2261 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2263 /* We have a multidimensional parameter. */
2264 for (s = ss; s; s = s->parent)
2266 int n;
2267 for (n = 0; n < s->loop->dimen; n++)
2269 s->loop->from[n] = gfc_index_zero_node;
2270 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2271 gfc_index_integer_kind);
2272 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2273 gfc_array_index_type,
2274 s->loop->to[n],
2275 gfc_index_one_node);
2280 if (*loop_ubound0 == NULL_TREE)
2282 mpz_t size;
2284 /* We should have a 1-dimensional, zero-based loop. */
2285 gcc_assert (loop->parent == NULL && loop->nested == NULL);
2286 gcc_assert (loop->dimen == 1);
2287 gcc_assert (integer_zerop (loop->from[0]));
2289 /* Split the constructor size into a static part and a dynamic part.
2290 Allocate the static size up-front and record whether the dynamic
2291 size might be nonzero. */
2292 mpz_init (size);
2293 dynamic = gfc_get_array_constructor_size (&size, c);
2294 mpz_sub_ui (size, size, 1);
2295 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2296 mpz_clear (size);
2299 /* Special case constant array constructors. */
2300 if (!dynamic)
2302 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2303 if (nelem > 0)
2305 tree size = constant_array_constructor_loop_size (loop);
2306 if (size && compare_tree_int (size, nelem) == 0)
2308 trans_constant_array_constructor (ss, type);
2309 goto finish;
2314 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2315 NULL_TREE, dynamic, true, false, where);
2317 desc = ss_info->data.array.descriptor;
2318 offset = gfc_index_zero_node;
2319 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2320 TREE_NO_WARNING (offsetvar) = 1;
2321 TREE_USED (offsetvar) = 0;
2322 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
2323 &offset, &offsetvar, dynamic);
2325 /* If the array grows dynamically, the upper bound of the loop variable
2326 is determined by the array's final upper bound. */
2327 if (dynamic)
2329 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2330 gfc_array_index_type,
2331 offsetvar, gfc_index_one_node);
2332 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2333 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2334 if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
2335 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2336 else
2337 *loop_ubound0 = tmp;
2340 if (TREE_USED (offsetvar))
2341 pushdecl (offsetvar);
2342 else
2343 gcc_assert (INTEGER_CST_P (offset));
2345 #if 0
2346 /* Disable bound checking for now because it's probably broken. */
2347 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2349 gcc_unreachable ();
2351 #endif
2353 finish:
2354 /* Restore old values of globals. */
2355 first_len = old_first_len;
2356 first_len_val = old_first_len_val;
2357 typespec_chararray_ctor = old_typespec_chararray_ctor;
2361 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2362 called after evaluating all of INFO's vector dimensions. Go through
2363 each such vector dimension and see if we can now fill in any missing
2364 loop bounds. */
2366 static void
2367 set_vector_loop_bounds (gfc_ss * ss)
2369 gfc_loopinfo *loop, *outer_loop;
2370 gfc_array_info *info;
2371 gfc_se se;
2372 tree tmp;
2373 tree desc;
2374 tree zero;
2375 int n;
2376 int dim;
2378 outer_loop = outermost_loop (ss->loop);
2380 info = &ss->info->data.array;
2382 for (; ss; ss = ss->parent)
2384 loop = ss->loop;
2386 for (n = 0; n < loop->dimen; n++)
2388 dim = ss->dim[n];
2389 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2390 || loop->to[n] != NULL)
2391 continue;
2393 /* Loop variable N indexes vector dimension DIM, and we don't
2394 yet know the upper bound of loop variable N. Set it to the
2395 difference between the vector's upper and lower bounds. */
2396 gcc_assert (loop->from[n] == gfc_index_zero_node);
2397 gcc_assert (info->subscript[dim]
2398 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2400 gfc_init_se (&se, NULL);
2401 desc = info->subscript[dim]->info->data.array.descriptor;
2402 zero = gfc_rank_cst[0];
2403 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2404 gfc_array_index_type,
2405 gfc_conv_descriptor_ubound_get (desc, zero),
2406 gfc_conv_descriptor_lbound_get (desc, zero));
2407 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2408 loop->to[n] = tmp;
2414 /* Add the pre and post chains for all the scalar expressions in a SS chain
2415 to loop. This is called after the loop parameters have been calculated,
2416 but before the actual scalarizing loops. */
2418 static void
2419 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2420 locus * where)
2422 gfc_loopinfo *nested_loop, *outer_loop;
2423 gfc_se se;
2424 gfc_ss_info *ss_info;
2425 gfc_array_info *info;
2426 gfc_expr *expr;
2427 int n;
2429 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2430 arguments could get evaluated multiple times. */
2431 if (ss->is_alloc_lhs)
2432 return;
2434 outer_loop = outermost_loop (loop);
2436 /* TODO: This can generate bad code if there are ordering dependencies,
2437 e.g., a callee allocated function and an unknown size constructor. */
2438 gcc_assert (ss != NULL);
2440 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2442 gcc_assert (ss);
2444 /* Cross loop arrays are handled from within the most nested loop. */
2445 if (ss->nested_ss != NULL)
2446 continue;
2448 ss_info = ss->info;
2449 expr = ss_info->expr;
2450 info = &ss_info->data.array;
2452 switch (ss_info->type)
2454 case GFC_SS_SCALAR:
2455 /* Scalar expression. Evaluate this now. This includes elemental
2456 dimension indices, but not array section bounds. */
2457 gfc_init_se (&se, NULL);
2458 gfc_conv_expr (&se, expr);
2459 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2461 if (expr->ts.type != BT_CHARACTER)
2463 /* Move the evaluation of scalar expressions outside the
2464 scalarization loop, except for WHERE assignments. */
2465 if (subscript)
2466 se.expr = convert(gfc_array_index_type, se.expr);
2467 if (!ss_info->where)
2468 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2469 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2471 else
2472 gfc_add_block_to_block (&outer_loop->post, &se.post);
2474 ss_info->data.scalar.value = se.expr;
2475 ss_info->string_length = se.string_length;
2476 break;
2478 case GFC_SS_REFERENCE:
2479 /* Scalar argument to elemental procedure. */
2480 gfc_init_se (&se, NULL);
2481 if (ss_info->can_be_null_ref)
2483 /* If the actual argument can be absent (in other words, it can
2484 be a NULL reference), don't try to evaluate it; pass instead
2485 the reference directly. */
2486 gfc_conv_expr_reference (&se, expr);
2488 else
2490 /* Otherwise, evaluate the argument outside the loop and pass
2491 a reference to the value. */
2492 gfc_conv_expr (&se, expr);
2494 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2495 gfc_add_block_to_block (&outer_loop->post, &se.post);
2496 if (gfc_is_class_scalar_expr (expr))
2497 /* This is necessary because the dynamic type will always be
2498 large than the declared type. In consequence, assigning
2499 the value to a temporary could segfault.
2500 OOP-TODO: see if this is generally correct or is the value
2501 has to be written to an allocated temporary, whose address
2502 is passed via ss_info. */
2503 ss_info->data.scalar.value = se.expr;
2504 else
2505 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2506 &outer_loop->pre);
2508 ss_info->string_length = se.string_length;
2509 break;
2511 case GFC_SS_SECTION:
2512 /* Add the expressions for scalar and vector subscripts. */
2513 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2514 if (info->subscript[n])
2515 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2517 set_vector_loop_bounds (ss);
2518 break;
2520 case GFC_SS_VECTOR:
2521 /* Get the vector's descriptor and store it in SS. */
2522 gfc_init_se (&se, NULL);
2523 gfc_conv_expr_descriptor (&se, expr);
2524 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2525 gfc_add_block_to_block (&outer_loop->post, &se.post);
2526 info->descriptor = se.expr;
2527 break;
2529 case GFC_SS_INTRINSIC:
2530 gfc_add_intrinsic_ss_code (loop, ss);
2531 break;
2533 case GFC_SS_FUNCTION:
2534 /* Array function return value. We call the function and save its
2535 result in a temporary for use inside the loop. */
2536 gfc_init_se (&se, NULL);
2537 se.loop = loop;
2538 se.ss = ss;
2539 gfc_conv_expr (&se, expr);
2540 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2541 gfc_add_block_to_block (&outer_loop->post, &se.post);
2542 ss_info->string_length = se.string_length;
2543 break;
2545 case GFC_SS_CONSTRUCTOR:
2546 if (expr->ts.type == BT_CHARACTER
2547 && ss_info->string_length == NULL
2548 && expr->ts.u.cl
2549 && expr->ts.u.cl->length)
2551 gfc_init_se (&se, NULL);
2552 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2553 gfc_charlen_type_node);
2554 ss_info->string_length = se.expr;
2555 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2556 gfc_add_block_to_block (&outer_loop->post, &se.post);
2558 trans_array_constructor (ss, where);
2559 break;
2561 case GFC_SS_TEMP:
2562 case GFC_SS_COMPONENT:
2563 /* Do nothing. These are handled elsewhere. */
2564 break;
2566 default:
2567 gcc_unreachable ();
2571 if (!subscript)
2572 for (nested_loop = loop->nested; nested_loop;
2573 nested_loop = nested_loop->next)
2574 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2578 /* Translate expressions for the descriptor and data pointer of a SS. */
2579 /*GCC ARRAYS*/
2581 static void
2582 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2584 gfc_se se;
2585 gfc_ss_info *ss_info;
2586 gfc_array_info *info;
2587 tree tmp;
2589 ss_info = ss->info;
2590 info = &ss_info->data.array;
2592 /* Get the descriptor for the array to be scalarized. */
2593 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2594 gfc_init_se (&se, NULL);
2595 se.descriptor_only = 1;
2596 gfc_conv_expr_lhs (&se, ss_info->expr);
2597 gfc_add_block_to_block (block, &se.pre);
2598 info->descriptor = se.expr;
2599 ss_info->string_length = se.string_length;
2601 if (base)
2603 /* Also the data pointer. */
2604 tmp = gfc_conv_array_data (se.expr);
2605 /* If this is a variable or address of a variable we use it directly.
2606 Otherwise we must evaluate it now to avoid breaking dependency
2607 analysis by pulling the expressions for elemental array indices
2608 inside the loop. */
2609 if (!(DECL_P (tmp)
2610 || (TREE_CODE (tmp) == ADDR_EXPR
2611 && DECL_P (TREE_OPERAND (tmp, 0)))))
2612 tmp = gfc_evaluate_now (tmp, block);
2613 info->data = tmp;
2615 tmp = gfc_conv_array_offset (se.expr);
2616 info->offset = gfc_evaluate_now (tmp, block);
2618 /* Make absolutely sure that the saved_offset is indeed saved
2619 so that the variable is still accessible after the loops
2620 are translated. */
2621 info->saved_offset = info->offset;
2626 /* Initialize a gfc_loopinfo structure. */
2628 void
2629 gfc_init_loopinfo (gfc_loopinfo * loop)
2631 int n;
2633 memset (loop, 0, sizeof (gfc_loopinfo));
2634 gfc_init_block (&loop->pre);
2635 gfc_init_block (&loop->post);
2637 /* Initially scalarize in order and default to no loop reversal. */
2638 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2640 loop->order[n] = n;
2641 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2644 loop->ss = gfc_ss_terminator;
2648 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2649 chain. */
2651 void
2652 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2654 se->loop = loop;
2658 /* Return an expression for the data pointer of an array. */
2660 tree
2661 gfc_conv_array_data (tree descriptor)
2663 tree type;
2665 type = TREE_TYPE (descriptor);
2666 if (GFC_ARRAY_TYPE_P (type))
2668 if (TREE_CODE (type) == POINTER_TYPE)
2669 return descriptor;
2670 else
2672 /* Descriptorless arrays. */
2673 return gfc_build_addr_expr (NULL_TREE, descriptor);
2676 else
2677 return gfc_conv_descriptor_data_get (descriptor);
2681 /* Return an expression for the base offset of an array. */
2683 tree
2684 gfc_conv_array_offset (tree descriptor)
2686 tree type;
2688 type = TREE_TYPE (descriptor);
2689 if (GFC_ARRAY_TYPE_P (type))
2690 return GFC_TYPE_ARRAY_OFFSET (type);
2691 else
2692 return gfc_conv_descriptor_offset_get (descriptor);
2696 /* Get an expression for the array stride. */
2698 tree
2699 gfc_conv_array_stride (tree descriptor, int dim)
2701 tree tmp;
2702 tree type;
2704 type = TREE_TYPE (descriptor);
2706 /* For descriptorless arrays use the array size. */
2707 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2708 if (tmp != NULL_TREE)
2709 return tmp;
2711 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2712 return tmp;
2716 /* Like gfc_conv_array_stride, but for the lower bound. */
2718 tree
2719 gfc_conv_array_lbound (tree descriptor, int dim)
2721 tree tmp;
2722 tree type;
2724 type = TREE_TYPE (descriptor);
2726 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2727 if (tmp != NULL_TREE)
2728 return tmp;
2730 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2731 return tmp;
2735 /* Like gfc_conv_array_stride, but for the upper bound. */
2737 tree
2738 gfc_conv_array_ubound (tree descriptor, int dim)
2740 tree tmp;
2741 tree type;
2743 type = TREE_TYPE (descriptor);
2745 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2746 if (tmp != NULL_TREE)
2747 return tmp;
2749 /* This should only ever happen when passing an assumed shape array
2750 as an actual parameter. The value will never be used. */
2751 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2752 return gfc_index_zero_node;
2754 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2755 return tmp;
2759 /* Generate code to perform an array index bound check. */
2761 static tree
2762 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2763 locus * where, bool check_upper)
2765 tree fault;
2766 tree tmp_lo, tmp_up;
2767 tree descriptor;
2768 char *msg;
2769 const char * name = NULL;
2771 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2772 return index;
2774 descriptor = ss->info->data.array.descriptor;
2776 index = gfc_evaluate_now (index, &se->pre);
2778 /* We find a name for the error message. */
2779 name = ss->info->expr->symtree->n.sym->name;
2780 gcc_assert (name != NULL);
2782 if (TREE_CODE (descriptor) == VAR_DECL)
2783 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2785 /* If upper bound is present, include both bounds in the error message. */
2786 if (check_upper)
2788 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2789 tmp_up = gfc_conv_array_ubound (descriptor, n);
2791 if (name)
2792 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2793 "outside of expected range (%%ld:%%ld)", n+1, name);
2794 else
2795 asprintf (&msg, "Index '%%ld' of dimension %d "
2796 "outside of expected range (%%ld:%%ld)", n+1);
2798 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2799 index, tmp_lo);
2800 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2801 fold_convert (long_integer_type_node, index),
2802 fold_convert (long_integer_type_node, tmp_lo),
2803 fold_convert (long_integer_type_node, tmp_up));
2804 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2805 index, tmp_up);
2806 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2807 fold_convert (long_integer_type_node, index),
2808 fold_convert (long_integer_type_node, tmp_lo),
2809 fold_convert (long_integer_type_node, tmp_up));
2810 free (msg);
2812 else
2814 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2816 if (name)
2817 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2818 "below lower bound of %%ld", n+1, name);
2819 else
2820 asprintf (&msg, "Index '%%ld' of dimension %d "
2821 "below lower bound of %%ld", n+1);
2823 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2824 index, tmp_lo);
2825 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2826 fold_convert (long_integer_type_node, index),
2827 fold_convert (long_integer_type_node, tmp_lo));
2828 free (msg);
2831 return index;
2835 /* Return the offset for an index. Performs bound checking for elemental
2836 dimensions. Single element references are processed separately.
2837 DIM is the array dimension, I is the loop dimension. */
2839 static tree
2840 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2841 gfc_array_ref * ar, tree stride)
2843 gfc_array_info *info;
2844 tree index;
2845 tree desc;
2846 tree data;
2848 info = &ss->info->data.array;
2850 /* Get the index into the array for this dimension. */
2851 if (ar)
2853 gcc_assert (ar->type != AR_ELEMENT);
2854 switch (ar->dimen_type[dim])
2856 case DIMEN_THIS_IMAGE:
2857 gcc_unreachable ();
2858 break;
2859 case DIMEN_ELEMENT:
2860 /* Elemental dimension. */
2861 gcc_assert (info->subscript[dim]
2862 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2863 /* We've already translated this value outside the loop. */
2864 index = info->subscript[dim]->info->data.scalar.value;
2866 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2867 ar->as->type != AS_ASSUMED_SIZE
2868 || dim < ar->dimen - 1);
2869 break;
2871 case DIMEN_VECTOR:
2872 gcc_assert (info && se->loop);
2873 gcc_assert (info->subscript[dim]
2874 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2875 desc = info->subscript[dim]->info->data.array.descriptor;
2877 /* Get a zero-based index into the vector. */
2878 index = fold_build2_loc (input_location, MINUS_EXPR,
2879 gfc_array_index_type,
2880 se->loop->loopvar[i], se->loop->from[i]);
2882 /* Multiply the index by the stride. */
2883 index = fold_build2_loc (input_location, MULT_EXPR,
2884 gfc_array_index_type,
2885 index, gfc_conv_array_stride (desc, 0));
2887 /* Read the vector to get an index into info->descriptor. */
2888 data = build_fold_indirect_ref_loc (input_location,
2889 gfc_conv_array_data (desc));
2890 index = gfc_build_array_ref (data, index, NULL);
2891 index = gfc_evaluate_now (index, &se->pre);
2892 index = fold_convert (gfc_array_index_type, index);
2894 /* Do any bounds checking on the final info->descriptor index. */
2895 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2896 ar->as->type != AS_ASSUMED_SIZE
2897 || dim < ar->dimen - 1);
2898 break;
2900 case DIMEN_RANGE:
2901 /* Scalarized dimension. */
2902 gcc_assert (info && se->loop);
2904 /* Multiply the loop variable by the stride and delta. */
2905 index = se->loop->loopvar[i];
2906 if (!integer_onep (info->stride[dim]))
2907 index = fold_build2_loc (input_location, MULT_EXPR,
2908 gfc_array_index_type, index,
2909 info->stride[dim]);
2910 if (!integer_zerop (info->delta[dim]))
2911 index = fold_build2_loc (input_location, PLUS_EXPR,
2912 gfc_array_index_type, index,
2913 info->delta[dim]);
2914 break;
2916 default:
2917 gcc_unreachable ();
2920 else
2922 /* Temporary array or derived type component. */
2923 gcc_assert (se->loop);
2924 index = se->loop->loopvar[se->loop->order[i]];
2926 /* Pointer functions can have stride[0] different from unity.
2927 Use the stride returned by the function call and stored in
2928 the descriptor for the temporary. */
2929 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2930 && se->ss->info->expr
2931 && se->ss->info->expr->symtree
2932 && se->ss->info->expr->symtree->n.sym->result
2933 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2934 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2935 gfc_rank_cst[dim]);
2937 if (!integer_zerop (info->delta[dim]))
2938 index = fold_build2_loc (input_location, PLUS_EXPR,
2939 gfc_array_index_type, index, info->delta[dim]);
2942 /* Multiply by the stride. */
2943 if (!integer_onep (stride))
2944 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2945 index, stride);
2947 return index;
2951 /* Build a scalarized array reference using the vptr 'size'. */
2953 static bool
2954 build_class_array_ref (gfc_se *se, tree base, tree index)
2956 tree type;
2957 tree size;
2958 tree offset;
2959 tree decl;
2960 tree tmp;
2961 gfc_expr *expr = se->ss->info->expr;
2962 gfc_ref *ref;
2963 gfc_ref *class_ref;
2964 gfc_typespec *ts;
2966 if (expr == NULL || expr->ts.type != BT_CLASS)
2967 return false;
2969 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
2970 ts = &expr->symtree->n.sym->ts;
2971 else
2972 ts = NULL;
2973 class_ref = NULL;
2975 for (ref = expr->ref; ref; ref = ref->next)
2977 if (ref->type == REF_COMPONENT
2978 && ref->u.c.component->ts.type == BT_CLASS
2979 && ref->next && ref->next->type == REF_COMPONENT
2980 && strcmp (ref->next->u.c.component->name, "_data") == 0
2981 && ref->next->next
2982 && ref->next->next->type == REF_ARRAY
2983 && ref->next->next->u.ar.type != AR_ELEMENT)
2985 ts = &ref->u.c.component->ts;
2986 class_ref = ref;
2987 break;
2991 if (ts == NULL)
2992 return false;
2994 if (class_ref == NULL && expr->symtree->n.sym->attr.function
2995 && expr->symtree->n.sym == expr->symtree->n.sym->result)
2997 gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
2998 decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
3000 else if (class_ref == NULL)
3001 decl = expr->symtree->n.sym->backend_decl;
3002 else
3004 /* Remove everything after the last class reference, convert the
3005 expression and then recover its tailend once more. */
3006 gfc_se tmpse;
3007 ref = class_ref->next;
3008 class_ref->next = NULL;
3009 gfc_init_se (&tmpse, NULL);
3010 gfc_conv_expr (&tmpse, expr);
3011 decl = tmpse.expr;
3012 class_ref->next = ref;
3015 size = gfc_vtable_size_get (decl);
3017 /* Build the address of the element. */
3018 type = TREE_TYPE (TREE_TYPE (base));
3019 size = fold_convert (TREE_TYPE (index), size);
3020 offset = fold_build2_loc (input_location, MULT_EXPR,
3021 gfc_array_index_type,
3022 index, size);
3023 tmp = gfc_build_addr_expr (pvoid_type_node, base);
3024 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
3025 tmp = fold_convert (build_pointer_type (type), tmp);
3027 /* Return the element in the se expression. */
3028 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
3029 return true;
3033 /* Build a scalarized reference to an array. */
3035 static void
3036 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3038 gfc_array_info *info;
3039 tree decl = NULL_TREE;
3040 tree index;
3041 tree tmp;
3042 gfc_ss *ss;
3043 gfc_expr *expr;
3044 int n;
3046 ss = se->ss;
3047 expr = ss->info->expr;
3048 info = &ss->info->data.array;
3049 if (ar)
3050 n = se->loop->order[0];
3051 else
3052 n = 0;
3054 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3055 /* Add the offset for this dimension to the stored offset for all other
3056 dimensions. */
3057 if (!integer_zerop (info->offset))
3058 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3059 index, info->offset);
3061 if (expr && is_subref_array (expr))
3062 decl = expr->symtree->n.sym->backend_decl;
3064 tmp = build_fold_indirect_ref_loc (input_location, info->data);
3066 /* Use the vptr 'size' field to access a class the element of a class
3067 array. */
3068 if (build_class_array_ref (se, tmp, index))
3069 return;
3071 se->expr = gfc_build_array_ref (tmp, index, decl);
3075 /* Translate access of temporary array. */
3077 void
3078 gfc_conv_tmp_array_ref (gfc_se * se)
3080 se->string_length = se->ss->info->string_length;
3081 gfc_conv_scalarized_array_ref (se, NULL);
3082 gfc_advance_se_ss_chain (se);
3085 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3087 static void
3088 add_to_offset (tree *cst_offset, tree *offset, tree t)
3090 if (TREE_CODE (t) == INTEGER_CST)
3091 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3092 else
3094 if (!integer_zerop (*offset))
3095 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3096 gfc_array_index_type, *offset, t);
3097 else
3098 *offset = t;
3103 static tree
3104 build_array_ref (tree desc, tree offset, tree decl)
3106 tree tmp;
3107 tree type;
3109 /* Class container types do not always have the GFC_CLASS_TYPE_P
3110 but the canonical type does. */
3111 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
3112 && TREE_CODE (desc) == COMPONENT_REF)
3114 type = TREE_TYPE (TREE_OPERAND (desc, 0));
3115 if (TYPE_CANONICAL (type)
3116 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
3117 type = TYPE_CANONICAL (type);
3119 else
3120 type = NULL;
3122 /* Class array references need special treatment because the assigned
3123 type size needs to be used to point to the element. */
3124 if (type && GFC_CLASS_TYPE_P (type))
3126 type = gfc_get_element_type (TREE_TYPE (desc));
3127 tmp = TREE_OPERAND (desc, 0);
3128 tmp = gfc_get_class_array_ref (offset, tmp);
3129 tmp = fold_convert (build_pointer_type (type), tmp);
3130 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3131 return tmp;
3134 tmp = gfc_conv_array_data (desc);
3135 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3136 tmp = gfc_build_array_ref (tmp, offset, decl);
3137 return tmp;
3141 /* Build an array reference. se->expr already holds the array descriptor.
3142 This should be either a variable, indirect variable reference or component
3143 reference. For arrays which do not have a descriptor, se->expr will be
3144 the data pointer.
3145 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3147 void
3148 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3149 locus * where)
3151 int n;
3152 tree offset, cst_offset;
3153 tree tmp;
3154 tree stride;
3155 gfc_se indexse;
3156 gfc_se tmpse;
3157 gfc_symbol * sym = expr->symtree->n.sym;
3158 char *var_name = NULL;
3160 if (ar->dimen == 0)
3162 gcc_assert (ar->codimen);
3164 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3165 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3166 else
3168 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3169 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3170 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3172 /* Use the actual tree type and not the wrapped coarray. */
3173 if (!se->want_pointer)
3174 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3175 se->expr);
3178 return;
3181 /* Handle scalarized references separately. */
3182 if (ar->type != AR_ELEMENT)
3184 gfc_conv_scalarized_array_ref (se, ar);
3185 gfc_advance_se_ss_chain (se);
3186 return;
3189 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3191 size_t len;
3192 gfc_ref *ref;
3194 len = strlen (sym->name) + 1;
3195 for (ref = expr->ref; ref; ref = ref->next)
3197 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3198 break;
3199 if (ref->type == REF_COMPONENT)
3200 len += 1 + strlen (ref->u.c.component->name);
3203 var_name = XALLOCAVEC (char, len);
3204 strcpy (var_name, sym->name);
3206 for (ref = expr->ref; ref; ref = ref->next)
3208 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3209 break;
3210 if (ref->type == REF_COMPONENT)
3212 strcat (var_name, "%%");
3213 strcat (var_name, ref->u.c.component->name);
3218 cst_offset = offset = gfc_index_zero_node;
3219 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3221 /* Calculate the offsets from all the dimensions. Make sure to associate
3222 the final offset so that we form a chain of loop invariant summands. */
3223 for (n = ar->dimen - 1; n >= 0; n--)
3225 /* Calculate the index for this dimension. */
3226 gfc_init_se (&indexse, se);
3227 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3228 gfc_add_block_to_block (&se->pre, &indexse.pre);
3230 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3232 /* Check array bounds. */
3233 tree cond;
3234 char *msg;
3236 /* Evaluate the indexse.expr only once. */
3237 indexse.expr = save_expr (indexse.expr);
3239 /* Lower bound. */
3240 tmp = gfc_conv_array_lbound (se->expr, n);
3241 if (sym->attr.temporary)
3243 gfc_init_se (&tmpse, se);
3244 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3245 gfc_array_index_type);
3246 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3247 tmp = tmpse.expr;
3250 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3251 indexse.expr, tmp);
3252 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3253 "below lower bound of %%ld", n+1, var_name);
3254 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3255 fold_convert (long_integer_type_node,
3256 indexse.expr),
3257 fold_convert (long_integer_type_node, tmp));
3258 free (msg);
3260 /* Upper bound, but not for the last dimension of assumed-size
3261 arrays. */
3262 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3264 tmp = gfc_conv_array_ubound (se->expr, n);
3265 if (sym->attr.temporary)
3267 gfc_init_se (&tmpse, se);
3268 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3269 gfc_array_index_type);
3270 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3271 tmp = tmpse.expr;
3274 cond = fold_build2_loc (input_location, GT_EXPR,
3275 boolean_type_node, indexse.expr, tmp);
3276 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3277 "above upper bound of %%ld", n+1, var_name);
3278 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3279 fold_convert (long_integer_type_node,
3280 indexse.expr),
3281 fold_convert (long_integer_type_node, tmp));
3282 free (msg);
3286 /* Multiply the index by the stride. */
3287 stride = gfc_conv_array_stride (se->expr, n);
3288 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3289 indexse.expr, stride);
3291 /* And add it to the total. */
3292 add_to_offset (&cst_offset, &offset, tmp);
3295 if (!integer_zerop (cst_offset))
3296 offset = fold_build2_loc (input_location, PLUS_EXPR,
3297 gfc_array_index_type, offset, cst_offset);
3299 se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
3303 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3304 LOOP_DIM dimension (if any) to array's offset. */
3306 static void
3307 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3308 gfc_array_ref *ar, int array_dim, int loop_dim)
3310 gfc_se se;
3311 gfc_array_info *info;
3312 tree stride, index;
3314 info = &ss->info->data.array;
3316 gfc_init_se (&se, NULL);
3317 se.loop = loop;
3318 se.expr = info->descriptor;
3319 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3320 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3321 gfc_add_block_to_block (pblock, &se.pre);
3323 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3324 gfc_array_index_type,
3325 info->offset, index);
3326 info->offset = gfc_evaluate_now (info->offset, pblock);
3330 /* Generate the code to be executed immediately before entering a
3331 scalarization loop. */
3333 static void
3334 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3335 stmtblock_t * pblock)
3337 tree stride;
3338 gfc_ss_info *ss_info;
3339 gfc_array_info *info;
3340 gfc_ss_type ss_type;
3341 gfc_ss *ss, *pss;
3342 gfc_loopinfo *ploop;
3343 gfc_array_ref *ar;
3344 int i;
3346 /* This code will be executed before entering the scalarization loop
3347 for this dimension. */
3348 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3350 ss_info = ss->info;
3352 if ((ss_info->useflags & flag) == 0)
3353 continue;
3355 ss_type = ss_info->type;
3356 if (ss_type != GFC_SS_SECTION
3357 && ss_type != GFC_SS_FUNCTION
3358 && ss_type != GFC_SS_CONSTRUCTOR
3359 && ss_type != GFC_SS_COMPONENT)
3360 continue;
3362 info = &ss_info->data.array;
3364 gcc_assert (dim < ss->dimen);
3365 gcc_assert (ss->dimen == loop->dimen);
3367 if (info->ref)
3368 ar = &info->ref->u.ar;
3369 else
3370 ar = NULL;
3372 if (dim == loop->dimen - 1 && loop->parent != NULL)
3374 /* If we are in the outermost dimension of this loop, the previous
3375 dimension shall be in the parent loop. */
3376 gcc_assert (ss->parent != NULL);
3378 pss = ss->parent;
3379 ploop = loop->parent;
3381 /* ss and ss->parent are about the same array. */
3382 gcc_assert (ss_info == pss->info);
3384 else
3386 ploop = loop;
3387 pss = ss;
3390 if (dim == loop->dimen - 1)
3391 i = 0;
3392 else
3393 i = dim + 1;
3395 /* For the time being, there is no loop reordering. */
3396 gcc_assert (i == ploop->order[i]);
3397 i = ploop->order[i];
3399 if (dim == loop->dimen - 1 && loop->parent == NULL)
3401 stride = gfc_conv_array_stride (info->descriptor,
3402 innermost_ss (ss)->dim[i]);
3404 /* Calculate the stride of the innermost loop. Hopefully this will
3405 allow the backend optimizers to do their stuff more effectively.
3407 info->stride0 = gfc_evaluate_now (stride, pblock);
3409 /* For the outermost loop calculate the offset due to any
3410 elemental dimensions. It will have been initialized with the
3411 base offset of the array. */
3412 if (info->ref)
3414 for (i = 0; i < ar->dimen; i++)
3416 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3417 continue;
3419 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3423 else
3424 /* Add the offset for the previous loop dimension. */
3425 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3427 /* Remember this offset for the second loop. */
3428 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3429 info->saved_offset = info->offset;
3434 /* Start a scalarized expression. Creates a scope and declares loop
3435 variables. */
3437 void
3438 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3440 int dim;
3441 int n;
3442 int flags;
3444 gcc_assert (!loop->array_parameter);
3446 for (dim = loop->dimen - 1; dim >= 0; dim--)
3448 n = loop->order[dim];
3450 gfc_start_block (&loop->code[n]);
3452 /* Create the loop variable. */
3453 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3455 if (dim < loop->temp_dim)
3456 flags = 3;
3457 else
3458 flags = 1;
3459 /* Calculate values that will be constant within this loop. */
3460 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3462 gfc_start_block (pbody);
3466 /* Generates the actual loop code for a scalarization loop. */
3468 void
3469 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3470 stmtblock_t * pbody)
3472 stmtblock_t block;
3473 tree cond;
3474 tree tmp;
3475 tree loopbody;
3476 tree exit_label;
3477 tree stmt;
3478 tree init;
3479 tree incr;
3481 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3482 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3483 && n == loop->dimen - 1)
3485 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3486 init = make_tree_vec (1);
3487 cond = make_tree_vec (1);
3488 incr = make_tree_vec (1);
3490 /* Cycle statement is implemented with a goto. Exit statement must not
3491 be present for this loop. */
3492 exit_label = gfc_build_label_decl (NULL_TREE);
3493 TREE_USED (exit_label) = 1;
3495 /* Label for cycle statements (if needed). */
3496 tmp = build1_v (LABEL_EXPR, exit_label);
3497 gfc_add_expr_to_block (pbody, tmp);
3499 stmt = make_node (OMP_FOR);
3501 TREE_TYPE (stmt) = void_type_node;
3502 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3504 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3505 OMP_CLAUSE_SCHEDULE);
3506 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3507 = OMP_CLAUSE_SCHEDULE_STATIC;
3508 if (ompws_flags & OMPWS_NOWAIT)
3509 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3510 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3512 /* Initialize the loopvar. */
3513 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3514 loop->from[n]);
3515 OMP_FOR_INIT (stmt) = init;
3516 /* The exit condition. */
3517 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3518 boolean_type_node,
3519 loop->loopvar[n], loop->to[n]);
3520 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3521 OMP_FOR_COND (stmt) = cond;
3522 /* Increment the loopvar. */
3523 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3524 loop->loopvar[n], gfc_index_one_node);
3525 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3526 void_type_node, loop->loopvar[n], tmp);
3527 OMP_FOR_INCR (stmt) = incr;
3529 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3530 gfc_add_expr_to_block (&loop->code[n], stmt);
3532 else
3534 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3535 && (loop->temp_ss == NULL);
3537 loopbody = gfc_finish_block (pbody);
3539 if (reverse_loop)
3541 tmp = loop->from[n];
3542 loop->from[n] = loop->to[n];
3543 loop->to[n] = tmp;
3546 /* Initialize the loopvar. */
3547 if (loop->loopvar[n] != loop->from[n])
3548 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3550 exit_label = gfc_build_label_decl (NULL_TREE);
3552 /* Generate the loop body. */
3553 gfc_init_block (&block);
3555 /* The exit condition. */
3556 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3557 boolean_type_node, loop->loopvar[n], loop->to[n]);
3558 tmp = build1_v (GOTO_EXPR, exit_label);
3559 TREE_USED (exit_label) = 1;
3560 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3561 gfc_add_expr_to_block (&block, tmp);
3563 /* The main body. */
3564 gfc_add_expr_to_block (&block, loopbody);
3566 /* Increment the loopvar. */
3567 tmp = fold_build2_loc (input_location,
3568 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3569 gfc_array_index_type, loop->loopvar[n],
3570 gfc_index_one_node);
3572 gfc_add_modify (&block, loop->loopvar[n], tmp);
3574 /* Build the loop. */
3575 tmp = gfc_finish_block (&block);
3576 tmp = build1_v (LOOP_EXPR, tmp);
3577 gfc_add_expr_to_block (&loop->code[n], tmp);
3579 /* Add the exit label. */
3580 tmp = build1_v (LABEL_EXPR, exit_label);
3581 gfc_add_expr_to_block (&loop->code[n], tmp);
3587 /* Finishes and generates the loops for a scalarized expression. */
3589 void
3590 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3592 int dim;
3593 int n;
3594 gfc_ss *ss;
3595 stmtblock_t *pblock;
3596 tree tmp;
3598 pblock = body;
3599 /* Generate the loops. */
3600 for (dim = 0; dim < loop->dimen; dim++)
3602 n = loop->order[dim];
3603 gfc_trans_scalarized_loop_end (loop, n, pblock);
3604 loop->loopvar[n] = NULL_TREE;
3605 pblock = &loop->code[n];
3608 tmp = gfc_finish_block (pblock);
3609 gfc_add_expr_to_block (&loop->pre, tmp);
3611 /* Clear all the used flags. */
3612 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3613 if (ss->parent == NULL)
3614 ss->info->useflags = 0;
3618 /* Finish the main body of a scalarized expression, and start the secondary
3619 copying body. */
3621 void
3622 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3624 int dim;
3625 int n;
3626 stmtblock_t *pblock;
3627 gfc_ss *ss;
3629 pblock = body;
3630 /* We finish as many loops as are used by the temporary. */
3631 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3633 n = loop->order[dim];
3634 gfc_trans_scalarized_loop_end (loop, n, pblock);
3635 loop->loopvar[n] = NULL_TREE;
3636 pblock = &loop->code[n];
3639 /* We don't want to finish the outermost loop entirely. */
3640 n = loop->order[loop->temp_dim - 1];
3641 gfc_trans_scalarized_loop_end (loop, n, pblock);
3643 /* Restore the initial offsets. */
3644 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3646 gfc_ss_type ss_type;
3647 gfc_ss_info *ss_info;
3649 ss_info = ss->info;
3651 if ((ss_info->useflags & 2) == 0)
3652 continue;
3654 ss_type = ss_info->type;
3655 if (ss_type != GFC_SS_SECTION
3656 && ss_type != GFC_SS_FUNCTION
3657 && ss_type != GFC_SS_CONSTRUCTOR
3658 && ss_type != GFC_SS_COMPONENT)
3659 continue;
3661 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3664 /* Restart all the inner loops we just finished. */
3665 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3667 n = loop->order[dim];
3669 gfc_start_block (&loop->code[n]);
3671 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3673 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3676 /* Start a block for the secondary copying code. */
3677 gfc_start_block (body);
3681 /* Precalculate (either lower or upper) bound of an array section.
3682 BLOCK: Block in which the (pre)calculation code will go.
3683 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3684 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3685 DESC: Array descriptor from which the bound will be picked if unspecified
3686 (either lower or upper bound according to LBOUND). */
3688 static void
3689 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3690 tree desc, int dim, bool lbound)
3692 gfc_se se;
3693 gfc_expr * input_val = values[dim];
3694 tree *output = &bounds[dim];
3697 if (input_val)
3699 /* Specified section bound. */
3700 gfc_init_se (&se, NULL);
3701 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3702 gfc_add_block_to_block (block, &se.pre);
3703 *output = se.expr;
3705 else
3707 /* No specific bound specified so use the bound of the array. */
3708 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3709 gfc_conv_array_ubound (desc, dim);
3711 *output = gfc_evaluate_now (*output, block);
3715 /* Calculate the lower bound of an array section. */
3717 static void
3718 gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
3720 gfc_expr *stride = NULL;
3721 tree desc;
3722 gfc_se se;
3723 gfc_array_info *info;
3724 gfc_array_ref *ar;
3726 gcc_assert (ss->info->type == GFC_SS_SECTION);
3728 info = &ss->info->data.array;
3729 ar = &info->ref->u.ar;
3731 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3733 /* We use a zero-based index to access the vector. */
3734 info->start[dim] = gfc_index_zero_node;
3735 info->end[dim] = NULL;
3736 info->stride[dim] = gfc_index_one_node;
3737 return;
3740 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3741 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3742 desc = info->descriptor;
3743 stride = ar->stride[dim];
3745 /* Calculate the start of the range. For vector subscripts this will
3746 be the range of the vector. */
3747 evaluate_bound (block, info->start, ar->start, desc, dim, true);
3749 /* Similarly calculate the end. Although this is not used in the
3750 scalarizer, it is needed when checking bounds and where the end
3751 is an expression with side-effects. */
3752 evaluate_bound (block, info->end, ar->end, desc, dim, false);
3754 /* Calculate the stride. */
3755 if (stride == NULL)
3756 info->stride[dim] = gfc_index_one_node;
3757 else
3759 gfc_init_se (&se, NULL);
3760 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3761 gfc_add_block_to_block (block, &se.pre);
3762 info->stride[dim] = gfc_evaluate_now (se.expr, block);
3767 /* Calculates the range start and stride for a SS chain. Also gets the
3768 descriptor and data pointer. The range of vector subscripts is the size
3769 of the vector. Array bounds are also checked. */
3771 void
3772 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3774 int n;
3775 tree tmp;
3776 gfc_ss *ss;
3777 tree desc;
3779 gfc_loopinfo * const outer_loop = outermost_loop (loop);
3781 loop->dimen = 0;
3782 /* Determine the rank of the loop. */
3783 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3785 switch (ss->info->type)
3787 case GFC_SS_SECTION:
3788 case GFC_SS_CONSTRUCTOR:
3789 case GFC_SS_FUNCTION:
3790 case GFC_SS_COMPONENT:
3791 loop->dimen = ss->dimen;
3792 goto done;
3794 /* As usual, lbound and ubound are exceptions!. */
3795 case GFC_SS_INTRINSIC:
3796 switch (ss->info->expr->value.function.isym->id)
3798 case GFC_ISYM_LBOUND:
3799 case GFC_ISYM_UBOUND:
3800 case GFC_ISYM_LCOBOUND:
3801 case GFC_ISYM_UCOBOUND:
3802 case GFC_ISYM_THIS_IMAGE:
3803 loop->dimen = ss->dimen;
3804 goto done;
3806 default:
3807 break;
3810 default:
3811 break;
3815 /* We should have determined the rank of the expression by now. If
3816 not, that's bad news. */
3817 gcc_unreachable ();
3819 done:
3820 /* Loop over all the SS in the chain. */
3821 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3823 gfc_ss_info *ss_info;
3824 gfc_array_info *info;
3825 gfc_expr *expr;
3827 ss_info = ss->info;
3828 expr = ss_info->expr;
3829 info = &ss_info->data.array;
3831 if (expr && expr->shape && !info->shape)
3832 info->shape = expr->shape;
3834 switch (ss_info->type)
3836 case GFC_SS_SECTION:
3837 /* Get the descriptor for the array. If it is a cross loops array,
3838 we got the descriptor already in the outermost loop. */
3839 if (ss->parent == NULL)
3840 gfc_conv_ss_descriptor (&outer_loop->pre, ss,
3841 !loop->array_parameter);
3843 for (n = 0; n < ss->dimen; n++)
3844 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
3845 break;
3847 case GFC_SS_INTRINSIC:
3848 switch (expr->value.function.isym->id)
3850 /* Fall through to supply start and stride. */
3851 case GFC_ISYM_LBOUND:
3852 case GFC_ISYM_UBOUND:
3854 gfc_expr *arg;
3856 /* This is the variant without DIM=... */
3857 gcc_assert (expr->value.function.actual->next->expr == NULL);
3859 arg = expr->value.function.actual->expr;
3860 if (arg->rank == -1)
3862 gfc_se se;
3863 tree rank, tmp;
3865 /* The rank (hence the return value's shape) is unknown,
3866 we have to retrieve it. */
3867 gfc_init_se (&se, NULL);
3868 se.descriptor_only = 1;
3869 gfc_conv_expr (&se, arg);
3870 /* This is a bare variable, so there is no preliminary
3871 or cleanup code. */
3872 gcc_assert (se.pre.head == NULL_TREE
3873 && se.post.head == NULL_TREE);
3874 rank = gfc_conv_descriptor_rank (se.expr);
3875 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3876 gfc_array_index_type,
3877 fold_convert (gfc_array_index_type,
3878 rank),
3879 gfc_index_one_node);
3880 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
3881 info->start[0] = gfc_index_zero_node;
3882 info->stride[0] = gfc_index_one_node;
3883 continue;
3885 /* Otherwise fall through GFC_SS_FUNCTION. */
3887 case GFC_ISYM_LCOBOUND:
3888 case GFC_ISYM_UCOBOUND:
3889 case GFC_ISYM_THIS_IMAGE:
3890 break;
3892 default:
3893 continue;
3896 case GFC_SS_CONSTRUCTOR:
3897 case GFC_SS_FUNCTION:
3898 for (n = 0; n < ss->dimen; n++)
3900 int dim = ss->dim[n];
3902 info->start[dim] = gfc_index_zero_node;
3903 info->end[dim] = gfc_index_zero_node;
3904 info->stride[dim] = gfc_index_one_node;
3906 break;
3908 default:
3909 break;
3913 /* The rest is just runtime bound checking. */
3914 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3916 stmtblock_t block;
3917 tree lbound, ubound;
3918 tree end;
3919 tree size[GFC_MAX_DIMENSIONS];
3920 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3921 gfc_array_info *info;
3922 char *msg;
3923 int dim;
3925 gfc_start_block (&block);
3927 for (n = 0; n < loop->dimen; n++)
3928 size[n] = NULL_TREE;
3930 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3932 stmtblock_t inner;
3933 gfc_ss_info *ss_info;
3934 gfc_expr *expr;
3935 locus *expr_loc;
3936 const char *expr_name;
3938 ss_info = ss->info;
3939 if (ss_info->type != GFC_SS_SECTION)
3940 continue;
3942 /* Catch allocatable lhs in f2003. */
3943 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3944 continue;
3946 expr = ss_info->expr;
3947 expr_loc = &expr->where;
3948 expr_name = expr->symtree->name;
3950 gfc_start_block (&inner);
3952 /* TODO: range checking for mapped dimensions. */
3953 info = &ss_info->data.array;
3955 /* This code only checks ranges. Elemental and vector
3956 dimensions are checked later. */
3957 for (n = 0; n < loop->dimen; n++)
3959 bool check_upper;
3961 dim = ss->dim[n];
3962 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3963 continue;
3965 if (dim == info->ref->u.ar.dimen - 1
3966 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3967 check_upper = false;
3968 else
3969 check_upper = true;
3971 /* Zero stride is not allowed. */
3972 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3973 info->stride[dim], gfc_index_zero_node);
3974 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3975 "of array '%s'", dim + 1, expr_name);
3976 gfc_trans_runtime_check (true, false, tmp, &inner,
3977 expr_loc, msg);
3978 free (msg);
3980 desc = info->descriptor;
3982 /* This is the run-time equivalent of resolve.c's
3983 check_dimension(). The logical is more readable there
3984 than it is here, with all the trees. */
3985 lbound = gfc_conv_array_lbound (desc, dim);
3986 end = info->end[dim];
3987 if (check_upper)
3988 ubound = gfc_conv_array_ubound (desc, dim);
3989 else
3990 ubound = NULL;
3992 /* non_zerosized is true when the selected range is not
3993 empty. */
3994 stride_pos = fold_build2_loc (input_location, GT_EXPR,
3995 boolean_type_node, info->stride[dim],
3996 gfc_index_zero_node);
3997 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3998 info->start[dim], end);
3999 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4000 boolean_type_node, stride_pos, tmp);
4002 stride_neg = fold_build2_loc (input_location, LT_EXPR,
4003 boolean_type_node,
4004 info->stride[dim], gfc_index_zero_node);
4005 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4006 info->start[dim], end);
4007 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4008 boolean_type_node,
4009 stride_neg, tmp);
4010 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4011 boolean_type_node,
4012 stride_pos, stride_neg);
4014 /* Check the start of the range against the lower and upper
4015 bounds of the array, if the range is not empty.
4016 If upper bound is present, include both bounds in the
4017 error message. */
4018 if (check_upper)
4020 tmp = fold_build2_loc (input_location, LT_EXPR,
4021 boolean_type_node,
4022 info->start[dim], lbound);
4023 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4024 boolean_type_node,
4025 non_zerosized, tmp);
4026 tmp2 = fold_build2_loc (input_location, GT_EXPR,
4027 boolean_type_node,
4028 info->start[dim], ubound);
4029 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4030 boolean_type_node,
4031 non_zerosized, tmp2);
4032 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4033 "outside of expected range (%%ld:%%ld)",
4034 dim + 1, expr_name);
4035 gfc_trans_runtime_check (true, false, tmp, &inner,
4036 expr_loc, msg,
4037 fold_convert (long_integer_type_node, info->start[dim]),
4038 fold_convert (long_integer_type_node, lbound),
4039 fold_convert (long_integer_type_node, ubound));
4040 gfc_trans_runtime_check (true, false, tmp2, &inner,
4041 expr_loc, msg,
4042 fold_convert (long_integer_type_node, info->start[dim]),
4043 fold_convert (long_integer_type_node, lbound),
4044 fold_convert (long_integer_type_node, ubound));
4045 free (msg);
4047 else
4049 tmp = fold_build2_loc (input_location, LT_EXPR,
4050 boolean_type_node,
4051 info->start[dim], lbound);
4052 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4053 boolean_type_node, non_zerosized, tmp);
4054 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4055 "below lower bound of %%ld",
4056 dim + 1, expr_name);
4057 gfc_trans_runtime_check (true, false, tmp, &inner,
4058 expr_loc, msg,
4059 fold_convert (long_integer_type_node, info->start[dim]),
4060 fold_convert (long_integer_type_node, lbound));
4061 free (msg);
4064 /* Compute the last element of the range, which is not
4065 necessarily "end" (think 0:5:3, which doesn't contain 5)
4066 and check it against both lower and upper bounds. */
4068 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4069 gfc_array_index_type, end,
4070 info->start[dim]);
4071 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4072 gfc_array_index_type, tmp,
4073 info->stride[dim]);
4074 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4075 gfc_array_index_type, end, tmp);
4076 tmp2 = fold_build2_loc (input_location, LT_EXPR,
4077 boolean_type_node, tmp, lbound);
4078 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4079 boolean_type_node, non_zerosized, tmp2);
4080 if (check_upper)
4082 tmp3 = fold_build2_loc (input_location, GT_EXPR,
4083 boolean_type_node, tmp, ubound);
4084 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4085 boolean_type_node, non_zerosized, tmp3);
4086 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4087 "outside of expected range (%%ld:%%ld)",
4088 dim + 1, expr_name);
4089 gfc_trans_runtime_check (true, false, tmp2, &inner,
4090 expr_loc, msg,
4091 fold_convert (long_integer_type_node, tmp),
4092 fold_convert (long_integer_type_node, ubound),
4093 fold_convert (long_integer_type_node, lbound));
4094 gfc_trans_runtime_check (true, false, tmp3, &inner,
4095 expr_loc, msg,
4096 fold_convert (long_integer_type_node, tmp),
4097 fold_convert (long_integer_type_node, ubound),
4098 fold_convert (long_integer_type_node, lbound));
4099 free (msg);
4101 else
4103 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4104 "below lower bound of %%ld",
4105 dim + 1, expr_name);
4106 gfc_trans_runtime_check (true, false, tmp2, &inner,
4107 expr_loc, msg,
4108 fold_convert (long_integer_type_node, tmp),
4109 fold_convert (long_integer_type_node, lbound));
4110 free (msg);
4113 /* Check the section sizes match. */
4114 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4115 gfc_array_index_type, end,
4116 info->start[dim]);
4117 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4118 gfc_array_index_type, tmp,
4119 info->stride[dim]);
4120 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4121 gfc_array_index_type,
4122 gfc_index_one_node, tmp);
4123 tmp = fold_build2_loc (input_location, MAX_EXPR,
4124 gfc_array_index_type, tmp,
4125 build_int_cst (gfc_array_index_type, 0));
4126 /* We remember the size of the first section, and check all the
4127 others against this. */
4128 if (size[n])
4130 tmp3 = fold_build2_loc (input_location, NE_EXPR,
4131 boolean_type_node, tmp, size[n]);
4132 asprintf (&msg, "Array bound mismatch for dimension %d "
4133 "of array '%s' (%%ld/%%ld)",
4134 dim + 1, expr_name);
4136 gfc_trans_runtime_check (true, false, tmp3, &inner,
4137 expr_loc, msg,
4138 fold_convert (long_integer_type_node, tmp),
4139 fold_convert (long_integer_type_node, size[n]));
4141 free (msg);
4143 else
4144 size[n] = gfc_evaluate_now (tmp, &inner);
4147 tmp = gfc_finish_block (&inner);
4149 /* For optional arguments, only check bounds if the argument is
4150 present. */
4151 if (expr->symtree->n.sym->attr.optional
4152 || expr->symtree->n.sym->attr.not_always_present)
4153 tmp = build3_v (COND_EXPR,
4154 gfc_conv_expr_present (expr->symtree->n.sym),
4155 tmp, build_empty_stmt (input_location));
4157 gfc_add_expr_to_block (&block, tmp);
4161 tmp = gfc_finish_block (&block);
4162 gfc_add_expr_to_block (&outer_loop->pre, tmp);
4165 for (loop = loop->nested; loop; loop = loop->next)
4166 gfc_conv_ss_startstride (loop);
4169 /* Return true if both symbols could refer to the same data object. Does
4170 not take account of aliasing due to equivalence statements. */
4172 static int
4173 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4174 bool lsym_target, bool rsym_pointer, bool rsym_target)
4176 /* Aliasing isn't possible if the symbols have different base types. */
4177 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4178 return 0;
4180 /* Pointers can point to other pointers and target objects. */
4182 if ((lsym_pointer && (rsym_pointer || rsym_target))
4183 || (rsym_pointer && (lsym_pointer || lsym_target)))
4184 return 1;
4186 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4187 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4188 checked above. */
4189 if (lsym_target && rsym_target
4190 && ((lsym->attr.dummy && !lsym->attr.contiguous
4191 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4192 || (rsym->attr.dummy && !rsym->attr.contiguous
4193 && (!rsym->attr.dimension
4194 || rsym->as->type == AS_ASSUMED_SHAPE))))
4195 return 1;
4197 return 0;
4201 /* Return true if the two SS could be aliased, i.e. both point to the same data
4202 object. */
4203 /* TODO: resolve aliases based on frontend expressions. */
4205 static int
4206 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4208 gfc_ref *lref;
4209 gfc_ref *rref;
4210 gfc_expr *lexpr, *rexpr;
4211 gfc_symbol *lsym;
4212 gfc_symbol *rsym;
4213 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4215 lexpr = lss->info->expr;
4216 rexpr = rss->info->expr;
4218 lsym = lexpr->symtree->n.sym;
4219 rsym = rexpr->symtree->n.sym;
4221 lsym_pointer = lsym->attr.pointer;
4222 lsym_target = lsym->attr.target;
4223 rsym_pointer = rsym->attr.pointer;
4224 rsym_target = rsym->attr.target;
4226 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4227 rsym_pointer, rsym_target))
4228 return 1;
4230 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4231 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4232 return 0;
4234 /* For derived types we must check all the component types. We can ignore
4235 array references as these will have the same base type as the previous
4236 component ref. */
4237 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4239 if (lref->type != REF_COMPONENT)
4240 continue;
4242 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4243 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4245 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4246 rsym_pointer, rsym_target))
4247 return 1;
4249 if ((lsym_pointer && (rsym_pointer || rsym_target))
4250 || (rsym_pointer && (lsym_pointer || lsym_target)))
4252 if (gfc_compare_types (&lref->u.c.component->ts,
4253 &rsym->ts))
4254 return 1;
4257 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4258 rref = rref->next)
4260 if (rref->type != REF_COMPONENT)
4261 continue;
4263 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4264 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4266 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4267 lsym_pointer, lsym_target,
4268 rsym_pointer, rsym_target))
4269 return 1;
4271 if ((lsym_pointer && (rsym_pointer || rsym_target))
4272 || (rsym_pointer && (lsym_pointer || lsym_target)))
4274 if (gfc_compare_types (&lref->u.c.component->ts,
4275 &rref->u.c.sym->ts))
4276 return 1;
4277 if (gfc_compare_types (&lref->u.c.sym->ts,
4278 &rref->u.c.component->ts))
4279 return 1;
4280 if (gfc_compare_types (&lref->u.c.component->ts,
4281 &rref->u.c.component->ts))
4282 return 1;
4287 lsym_pointer = lsym->attr.pointer;
4288 lsym_target = lsym->attr.target;
4289 lsym_pointer = lsym->attr.pointer;
4290 lsym_target = lsym->attr.target;
4292 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4294 if (rref->type != REF_COMPONENT)
4295 break;
4297 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4298 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4300 if (symbols_could_alias (rref->u.c.sym, lsym,
4301 lsym_pointer, lsym_target,
4302 rsym_pointer, rsym_target))
4303 return 1;
4305 if ((lsym_pointer && (rsym_pointer || rsym_target))
4306 || (rsym_pointer && (lsym_pointer || lsym_target)))
4308 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4309 return 1;
4313 return 0;
4317 /* Resolve array data dependencies. Creates a temporary if required. */
4318 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4319 dependency.c. */
4321 void
4322 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4323 gfc_ss * rss)
4325 gfc_ss *ss;
4326 gfc_ref *lref;
4327 gfc_ref *rref;
4328 gfc_expr *dest_expr;
4329 gfc_expr *ss_expr;
4330 int nDepend = 0;
4331 int i, j;
4333 loop->temp_ss = NULL;
4334 dest_expr = dest->info->expr;
4336 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4338 ss_expr = ss->info->expr;
4340 if (ss->info->type != GFC_SS_SECTION)
4342 if (gfc_option.flag_realloc_lhs
4343 && dest_expr != ss_expr
4344 && gfc_is_reallocatable_lhs (dest_expr)
4345 && ss_expr->rank)
4346 nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
4348 continue;
4351 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4353 if (gfc_could_be_alias (dest, ss)
4354 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4356 nDepend = 1;
4357 break;
4360 else
4362 lref = dest_expr->ref;
4363 rref = ss_expr->ref;
4365 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4367 if (nDepend == 1)
4368 break;
4370 for (i = 0; i < dest->dimen; i++)
4371 for (j = 0; j < ss->dimen; j++)
4372 if (i != j
4373 && dest->dim[i] == ss->dim[j])
4375 /* If we don't access array elements in the same order,
4376 there is a dependency. */
4377 nDepend = 1;
4378 goto temporary;
4380 #if 0
4381 /* TODO : loop shifting. */
4382 if (nDepend == 1)
4384 /* Mark the dimensions for LOOP SHIFTING */
4385 for (n = 0; n < loop->dimen; n++)
4387 int dim = dest->data.info.dim[n];
4389 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4390 depends[n] = 2;
4391 else if (! gfc_is_same_range (&lref->u.ar,
4392 &rref->u.ar, dim, 0))
4393 depends[n] = 1;
4396 /* Put all the dimensions with dependencies in the
4397 innermost loops. */
4398 dim = 0;
4399 for (n = 0; n < loop->dimen; n++)
4401 gcc_assert (loop->order[n] == n);
4402 if (depends[n])
4403 loop->order[dim++] = n;
4405 for (n = 0; n < loop->dimen; n++)
4407 if (! depends[n])
4408 loop->order[dim++] = n;
4411 gcc_assert (dim == loop->dimen);
4412 break;
4414 #endif
4418 temporary:
4420 if (nDepend == 1)
4422 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4423 if (GFC_ARRAY_TYPE_P (base_type)
4424 || GFC_DESCRIPTOR_TYPE_P (base_type))
4425 base_type = gfc_get_element_type (base_type);
4426 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4427 loop->dimen);
4428 gfc_add_ss_to_loop (loop, loop->temp_ss);
4430 else
4431 loop->temp_ss = NULL;
4435 /* Browse through each array's information from the scalarizer and set the loop
4436 bounds according to the "best" one (per dimension), i.e. the one which
4437 provides the most information (constant bounds, shape, etc.). */
4439 static void
4440 set_loop_bounds (gfc_loopinfo *loop)
4442 int n, dim, spec_dim;
4443 gfc_array_info *info;
4444 gfc_array_info *specinfo;
4445 gfc_ss *ss;
4446 tree tmp;
4447 gfc_ss **loopspec;
4448 bool dynamic[GFC_MAX_DIMENSIONS];
4449 mpz_t *cshape;
4450 mpz_t i;
4451 bool nonoptional_arr;
4453 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4455 loopspec = loop->specloop;
4457 mpz_init (i);
4458 for (n = 0; n < loop->dimen; n++)
4460 loopspec[n] = NULL;
4461 dynamic[n] = false;
4463 /* If there are both optional and nonoptional array arguments, scalarize
4464 over the nonoptional; otherwise, it does not matter as then all
4465 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4467 nonoptional_arr = false;
4469 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4470 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
4471 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
4473 nonoptional_arr = true;
4474 break;
4477 /* We use one SS term, and use that to determine the bounds of the
4478 loop for this dimension. We try to pick the simplest term. */
4479 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4481 gfc_ss_type ss_type;
4483 ss_type = ss->info->type;
4484 if (ss_type == GFC_SS_SCALAR
4485 || ss_type == GFC_SS_TEMP
4486 || ss_type == GFC_SS_REFERENCE
4487 || (ss->info->can_be_null_ref && nonoptional_arr))
4488 continue;
4490 info = &ss->info->data.array;
4491 dim = ss->dim[n];
4493 if (loopspec[n] != NULL)
4495 specinfo = &loopspec[n]->info->data.array;
4496 spec_dim = loopspec[n]->dim[n];
4498 else
4500 /* Silence uninitialized warnings. */
4501 specinfo = NULL;
4502 spec_dim = 0;
4505 if (info->shape)
4507 gcc_assert (info->shape[dim]);
4508 /* The frontend has worked out the size for us. */
4509 if (!loopspec[n]
4510 || !specinfo->shape
4511 || !integer_zerop (specinfo->start[spec_dim]))
4512 /* Prefer zero-based descriptors if possible. */
4513 loopspec[n] = ss;
4514 continue;
4517 if (ss_type == GFC_SS_CONSTRUCTOR)
4519 gfc_constructor_base base;
4520 /* An unknown size constructor will always be rank one.
4521 Higher rank constructors will either have known shape,
4522 or still be wrapped in a call to reshape. */
4523 gcc_assert (loop->dimen == 1);
4525 /* Always prefer to use the constructor bounds if the size
4526 can be determined at compile time. Prefer not to otherwise,
4527 since the general case involves realloc, and it's better to
4528 avoid that overhead if possible. */
4529 base = ss->info->expr->value.constructor;
4530 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4531 if (!dynamic[n] || !loopspec[n])
4532 loopspec[n] = ss;
4533 continue;
4536 /* Avoid using an allocatable lhs in an assignment, since
4537 there might be a reallocation coming. */
4538 if (loopspec[n] && ss->is_alloc_lhs)
4539 continue;
4541 if (!loopspec[n])
4542 loopspec[n] = ss;
4543 /* Criteria for choosing a loop specifier (most important first):
4544 doesn't need realloc
4545 stride of one
4546 known stride
4547 known lower bound
4548 known upper bound
4550 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4551 loopspec[n] = ss;
4552 else if (integer_onep (info->stride[dim])
4553 && !integer_onep (specinfo->stride[spec_dim]))
4554 loopspec[n] = ss;
4555 else if (INTEGER_CST_P (info->stride[dim])
4556 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4557 loopspec[n] = ss;
4558 else if (INTEGER_CST_P (info->start[dim])
4559 && !INTEGER_CST_P (specinfo->start[spec_dim])
4560 && integer_onep (info->stride[dim])
4561 == integer_onep (specinfo->stride[spec_dim])
4562 && INTEGER_CST_P (info->stride[dim])
4563 == INTEGER_CST_P (specinfo->stride[spec_dim]))
4564 loopspec[n] = ss;
4565 /* We don't work out the upper bound.
4566 else if (INTEGER_CST_P (info->finish[n])
4567 && ! INTEGER_CST_P (specinfo->finish[n]))
4568 loopspec[n] = ss; */
4571 /* We should have found the scalarization loop specifier. If not,
4572 that's bad news. */
4573 gcc_assert (loopspec[n]);
4575 info = &loopspec[n]->info->data.array;
4576 dim = loopspec[n]->dim[n];
4578 /* Set the extents of this range. */
4579 cshape = info->shape;
4580 if (cshape && INTEGER_CST_P (info->start[dim])
4581 && INTEGER_CST_P (info->stride[dim]))
4583 loop->from[n] = info->start[dim];
4584 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
4585 mpz_sub_ui (i, i, 1);
4586 /* To = from + (size - 1) * stride. */
4587 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4588 if (!integer_onep (info->stride[dim]))
4589 tmp = fold_build2_loc (input_location, MULT_EXPR,
4590 gfc_array_index_type, tmp,
4591 info->stride[dim]);
4592 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4593 gfc_array_index_type,
4594 loop->from[n], tmp);
4596 else
4598 loop->from[n] = info->start[dim];
4599 switch (loopspec[n]->info->type)
4601 case GFC_SS_CONSTRUCTOR:
4602 /* The upper bound is calculated when we expand the
4603 constructor. */
4604 gcc_assert (loop->to[n] == NULL_TREE);
4605 break;
4607 case GFC_SS_SECTION:
4608 /* Use the end expression if it exists and is not constant,
4609 so that it is only evaluated once. */
4610 loop->to[n] = info->end[dim];
4611 break;
4613 case GFC_SS_FUNCTION:
4614 /* The loop bound will be set when we generate the call. */
4615 gcc_assert (loop->to[n] == NULL_TREE);
4616 break;
4618 case GFC_SS_INTRINSIC:
4620 gfc_expr *expr = loopspec[n]->info->expr;
4622 /* The {l,u}bound of an assumed rank. */
4623 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
4624 || expr->value.function.isym->id == GFC_ISYM_UBOUND)
4625 && expr->value.function.actual->next->expr == NULL
4626 && expr->value.function.actual->expr->rank == -1);
4628 loop->to[n] = info->end[dim];
4629 break;
4632 default:
4633 gcc_unreachable ();
4637 /* Transform everything so we have a simple incrementing variable. */
4638 if (integer_onep (info->stride[dim]))
4639 info->delta[dim] = gfc_index_zero_node;
4640 else
4642 /* Set the delta for this section. */
4643 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
4644 /* Number of iterations is (end - start + step) / step.
4645 with start = 0, this simplifies to
4646 last = end / step;
4647 for (i = 0; i<=last; i++){...}; */
4648 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4649 gfc_array_index_type, loop->to[n],
4650 loop->from[n]);
4651 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4652 gfc_array_index_type, tmp, info->stride[dim]);
4653 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4654 tmp, build_int_cst (gfc_array_index_type, -1));
4655 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
4656 /* Make the loop variable start at 0. */
4657 loop->from[n] = gfc_index_zero_node;
4660 mpz_clear (i);
4662 for (loop = loop->nested; loop; loop = loop->next)
4663 set_loop_bounds (loop);
4667 /* Initialize the scalarization loop. Creates the loop variables. Determines
4668 the range of the loop variables. Creates a temporary if required.
4669 Also generates code for scalar expressions which have been
4670 moved outside the loop. */
4672 void
4673 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4675 gfc_ss *tmp_ss;
4676 tree tmp;
4678 set_loop_bounds (loop);
4680 /* Add all the scalar code that can be taken out of the loops.
4681 This may include calculating the loop bounds, so do it before
4682 allocating the temporary. */
4683 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4685 tmp_ss = loop->temp_ss;
4686 /* If we want a temporary then create it. */
4687 if (tmp_ss != NULL)
4689 gfc_ss_info *tmp_ss_info;
4691 tmp_ss_info = tmp_ss->info;
4692 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4693 gcc_assert (loop->parent == NULL);
4695 /* Make absolutely sure that this is a complete type. */
4696 if (tmp_ss_info->string_length)
4697 tmp_ss_info->data.temp.type
4698 = gfc_get_character_type_len_for_eltype
4699 (TREE_TYPE (tmp_ss_info->data.temp.type),
4700 tmp_ss_info->string_length);
4702 tmp = tmp_ss_info->data.temp.type;
4703 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4704 tmp_ss_info->type = GFC_SS_SECTION;
4706 gcc_assert (tmp_ss->dimen != 0);
4708 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4709 NULL_TREE, false, true, false, where);
4712 /* For array parameters we don't have loop variables, so don't calculate the
4713 translations. */
4714 if (!loop->array_parameter)
4715 gfc_set_delta (loop);
4719 /* Calculates how to transform from loop variables to array indices for each
4720 array: once loop bounds are chosen, sets the difference (DELTA field) between
4721 loop bounds and array reference bounds, for each array info. */
4723 void
4724 gfc_set_delta (gfc_loopinfo *loop)
4726 gfc_ss *ss, **loopspec;
4727 gfc_array_info *info;
4728 tree tmp;
4729 int n, dim;
4731 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4733 loopspec = loop->specloop;
4735 /* Calculate the translation from loop variables to array indices. */
4736 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4738 gfc_ss_type ss_type;
4740 ss_type = ss->info->type;
4741 if (ss_type != GFC_SS_SECTION
4742 && ss_type != GFC_SS_COMPONENT
4743 && ss_type != GFC_SS_CONSTRUCTOR)
4744 continue;
4746 info = &ss->info->data.array;
4748 for (n = 0; n < ss->dimen; n++)
4750 /* If we are specifying the range the delta is already set. */
4751 if (loopspec[n] != ss)
4753 dim = ss->dim[n];
4755 /* Calculate the offset relative to the loop variable.
4756 First multiply by the stride. */
4757 tmp = loop->from[n];
4758 if (!integer_onep (info->stride[dim]))
4759 tmp = fold_build2_loc (input_location, MULT_EXPR,
4760 gfc_array_index_type,
4761 tmp, info->stride[dim]);
4763 /* Then subtract this from our starting value. */
4764 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4765 gfc_array_index_type,
4766 info->start[dim], tmp);
4768 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
4773 for (loop = loop->nested; loop; loop = loop->next)
4774 gfc_set_delta (loop);
4778 /* Calculate the size of a given array dimension from the bounds. This
4779 is simply (ubound - lbound + 1) if this expression is positive
4780 or 0 if it is negative (pick either one if it is zero). Optionally
4781 (if or_expr is present) OR the (expression != 0) condition to it. */
4783 tree
4784 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4786 tree res;
4787 tree cond;
4789 /* Calculate (ubound - lbound + 1). */
4790 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4791 ubound, lbound);
4792 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4793 gfc_index_one_node);
4795 /* Check whether the size for this dimension is negative. */
4796 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4797 gfc_index_zero_node);
4798 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4799 gfc_index_zero_node, res);
4801 /* Build OR expression. */
4802 if (or_expr)
4803 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4804 boolean_type_node, *or_expr, cond);
4806 return res;
4810 /* For an array descriptor, get the total number of elements. This is just
4811 the product of the extents along from_dim to to_dim. */
4813 static tree
4814 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4816 tree res;
4817 int dim;
4819 res = gfc_index_one_node;
4821 for (dim = from_dim; dim < to_dim; ++dim)
4823 tree lbound;
4824 tree ubound;
4825 tree extent;
4827 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4828 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4830 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4831 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4832 res, extent);
4835 return res;
4839 /* Full size of an array. */
4841 tree
4842 gfc_conv_descriptor_size (tree desc, int rank)
4844 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4848 /* Size of a coarray for all dimensions but the last. */
4850 tree
4851 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4853 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4857 /* Fills in an array descriptor, and returns the size of the array.
4858 The size will be a simple_val, ie a variable or a constant. Also
4859 calculates the offset of the base. The pointer argument overflow,
4860 which should be of integer type, will increase in value if overflow
4861 occurs during the size calculation. Returns the size of the array.
4863 stride = 1;
4864 offset = 0;
4865 for (n = 0; n < rank; n++)
4867 a.lbound[n] = specified_lower_bound;
4868 offset = offset + a.lbond[n] * stride;
4869 size = 1 - lbound;
4870 a.ubound[n] = specified_upper_bound;
4871 a.stride[n] = stride;
4872 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4873 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4874 stride = stride * size;
4876 for (n = rank; n < rank+corank; n++)
4877 (Set lcobound/ucobound as above.)
4878 element_size = sizeof (array element);
4879 if (!rank)
4880 return element_size
4881 stride = (size_t) stride;
4882 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4883 stride = stride * element_size;
4884 return (stride);
4885 } */
4886 /*GCC ARRAYS*/
4888 static tree
4889 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4890 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4891 stmtblock_t * descriptor_block, tree * overflow,
4892 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
4893 gfc_typespec *ts)
4895 tree type;
4896 tree tmp;
4897 tree size;
4898 tree offset;
4899 tree stride;
4900 tree element_size;
4901 tree or_expr;
4902 tree thencase;
4903 tree elsecase;
4904 tree cond;
4905 tree var;
4906 stmtblock_t thenblock;
4907 stmtblock_t elseblock;
4908 gfc_expr *ubound;
4909 gfc_se se;
4910 int n;
4912 type = TREE_TYPE (descriptor);
4914 stride = gfc_index_one_node;
4915 offset = gfc_index_zero_node;
4917 /* Set the dtype. */
4918 tmp = gfc_conv_descriptor_dtype (descriptor);
4919 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4921 or_expr = boolean_false_node;
4923 for (n = 0; n < rank; n++)
4925 tree conv_lbound;
4926 tree conv_ubound;
4928 /* We have 3 possibilities for determining the size of the array:
4929 lower == NULL => lbound = 1, ubound = upper[n]
4930 upper[n] = NULL => lbound = 1, ubound = lower[n]
4931 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4932 ubound = upper[n];
4934 /* Set lower bound. */
4935 gfc_init_se (&se, NULL);
4936 if (lower == NULL)
4937 se.expr = gfc_index_one_node;
4938 else
4940 gcc_assert (lower[n]);
4941 if (ubound)
4943 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4944 gfc_add_block_to_block (pblock, &se.pre);
4946 else
4948 se.expr = gfc_index_one_node;
4949 ubound = lower[n];
4952 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4953 gfc_rank_cst[n], se.expr);
4954 conv_lbound = se.expr;
4956 /* Work out the offset for this component. */
4957 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4958 se.expr, stride);
4959 offset = fold_build2_loc (input_location, MINUS_EXPR,
4960 gfc_array_index_type, offset, tmp);
4962 /* Set upper bound. */
4963 gfc_init_se (&se, NULL);
4964 gcc_assert (ubound);
4965 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4966 gfc_add_block_to_block (pblock, &se.pre);
4968 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4969 gfc_rank_cst[n], se.expr);
4970 conv_ubound = se.expr;
4972 /* Store the stride. */
4973 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4974 gfc_rank_cst[n], stride);
4976 /* Calculate size and check whether extent is negative. */
4977 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4978 size = gfc_evaluate_now (size, pblock);
4980 /* Check whether multiplying the stride by the number of
4981 elements in this dimension would overflow. We must also check
4982 whether the current dimension has zero size in order to avoid
4983 division by zero.
4985 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4986 gfc_array_index_type,
4987 fold_convert (gfc_array_index_type,
4988 TYPE_MAX_VALUE (gfc_array_index_type)),
4989 size);
4990 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4991 boolean_type_node, tmp, stride));
4992 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4993 integer_one_node, integer_zero_node);
4994 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
4995 boolean_type_node, size,
4996 gfc_index_zero_node));
4997 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4998 integer_zero_node, tmp);
4999 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5000 *overflow, tmp);
5001 *overflow = gfc_evaluate_now (tmp, pblock);
5003 /* Multiply the stride by the number of elements in this dimension. */
5004 stride = fold_build2_loc (input_location, MULT_EXPR,
5005 gfc_array_index_type, stride, size);
5006 stride = gfc_evaluate_now (stride, pblock);
5009 for (n = rank; n < rank + corank; n++)
5011 ubound = upper[n];
5013 /* Set lower bound. */
5014 gfc_init_se (&se, NULL);
5015 if (lower == NULL || lower[n] == NULL)
5017 gcc_assert (n == rank + corank - 1);
5018 se.expr = gfc_index_one_node;
5020 else
5022 if (ubound || n == rank + corank - 1)
5024 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5025 gfc_add_block_to_block (pblock, &se.pre);
5027 else
5029 se.expr = gfc_index_one_node;
5030 ubound = lower[n];
5033 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5034 gfc_rank_cst[n], se.expr);
5036 if (n < rank + corank - 1)
5038 gfc_init_se (&se, NULL);
5039 gcc_assert (ubound);
5040 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5041 gfc_add_block_to_block (pblock, &se.pre);
5042 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5043 gfc_rank_cst[n], se.expr);
5047 /* The stride is the number of elements in the array, so multiply by the
5048 size of an element to get the total size. Obviously, if there is a
5049 SOURCE expression (expr3) we must use its element size. */
5050 if (expr3_elem_size != NULL_TREE)
5051 tmp = expr3_elem_size;
5052 else if (expr3 != NULL)
5054 if (expr3->ts.type == BT_CLASS)
5056 gfc_se se_sz;
5057 gfc_expr *sz = gfc_copy_expr (expr3);
5058 gfc_add_vptr_component (sz);
5059 gfc_add_size_component (sz);
5060 gfc_init_se (&se_sz, NULL);
5061 gfc_conv_expr (&se_sz, sz);
5062 gfc_free_expr (sz);
5063 tmp = se_sz.expr;
5065 else
5067 tmp = gfc_typenode_for_spec (&expr3->ts);
5068 tmp = TYPE_SIZE_UNIT (tmp);
5071 else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
5072 /* FIXME: Properly handle characters. See PR 57456. */
5073 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
5074 else
5075 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5077 /* Convert to size_t. */
5078 element_size = fold_convert (size_type_node, tmp);
5080 if (rank == 0)
5081 return element_size;
5083 *nelems = gfc_evaluate_now (stride, pblock);
5084 stride = fold_convert (size_type_node, stride);
5086 /* First check for overflow. Since an array of type character can
5087 have zero element_size, we must check for that before
5088 dividing. */
5089 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5090 size_type_node,
5091 TYPE_MAX_VALUE (size_type_node), element_size);
5092 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5093 boolean_type_node, tmp, stride));
5094 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5095 integer_one_node, integer_zero_node);
5096 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5097 boolean_type_node, element_size,
5098 build_int_cst (size_type_node, 0)));
5099 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5100 integer_zero_node, tmp);
5101 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5102 *overflow, tmp);
5103 *overflow = gfc_evaluate_now (tmp, pblock);
5105 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5106 stride, element_size);
5108 if (poffset != NULL)
5110 offset = gfc_evaluate_now (offset, pblock);
5111 *poffset = offset;
5114 if (integer_zerop (or_expr))
5115 return size;
5116 if (integer_onep (or_expr))
5117 return build_int_cst (size_type_node, 0);
5119 var = gfc_create_var (TREE_TYPE (size), "size");
5120 gfc_start_block (&thenblock);
5121 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
5122 thencase = gfc_finish_block (&thenblock);
5124 gfc_start_block (&elseblock);
5125 gfc_add_modify (&elseblock, var, size);
5126 elsecase = gfc_finish_block (&elseblock);
5128 tmp = gfc_evaluate_now (or_expr, pblock);
5129 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
5130 gfc_add_expr_to_block (pblock, tmp);
5132 return var;
5136 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5137 the work for an ALLOCATE statement. */
5138 /*GCC ARRAYS*/
5140 bool
5141 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
5142 tree errlen, tree label_finish, tree expr3_elem_size,
5143 tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
5145 tree tmp;
5146 tree pointer;
5147 tree offset = NULL_TREE;
5148 tree token = NULL_TREE;
5149 tree size;
5150 tree msg;
5151 tree error = NULL_TREE;
5152 tree overflow; /* Boolean storing whether size calculation overflows. */
5153 tree var_overflow = NULL_TREE;
5154 tree cond;
5155 tree set_descriptor;
5156 stmtblock_t set_descriptor_block;
5157 stmtblock_t elseblock;
5158 gfc_expr **lower;
5159 gfc_expr **upper;
5160 gfc_ref *ref, *prev_ref = NULL;
5161 bool allocatable, coarray, dimension;
5163 ref = expr->ref;
5165 /* Find the last reference in the chain. */
5166 while (ref && ref->next != NULL)
5168 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
5169 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
5170 prev_ref = ref;
5171 ref = ref->next;
5174 if (ref == NULL || ref->type != REF_ARRAY)
5175 return false;
5177 if (!prev_ref)
5179 allocatable = expr->symtree->n.sym->attr.allocatable;
5180 coarray = expr->symtree->n.sym->attr.codimension;
5181 dimension = expr->symtree->n.sym->attr.dimension;
5183 else
5185 allocatable = prev_ref->u.c.component->attr.allocatable;
5186 coarray = prev_ref->u.c.component->attr.codimension;
5187 dimension = prev_ref->u.c.component->attr.dimension;
5190 if (!dimension)
5191 gcc_assert (coarray);
5193 /* Figure out the size of the array. */
5194 switch (ref->u.ar.type)
5196 case AR_ELEMENT:
5197 if (!coarray)
5199 lower = NULL;
5200 upper = ref->u.ar.start;
5201 break;
5203 /* Fall through. */
5205 case AR_SECTION:
5206 lower = ref->u.ar.start;
5207 upper = ref->u.ar.end;
5208 break;
5210 case AR_FULL:
5211 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
5213 lower = ref->u.ar.as->lower;
5214 upper = ref->u.ar.as->upper;
5215 break;
5217 default:
5218 gcc_unreachable ();
5219 break;
5222 overflow = integer_zero_node;
5224 gfc_init_block (&set_descriptor_block);
5225 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
5226 ref->u.ar.as->corank, &offset, lower, upper,
5227 &se->pre, &set_descriptor_block, &overflow,
5228 expr3_elem_size, nelems, expr3, ts);
5230 if (dimension)
5232 var_overflow = gfc_create_var (integer_type_node, "overflow");
5233 gfc_add_modify (&se->pre, var_overflow, overflow);
5235 if (status == NULL_TREE)
5237 /* Generate the block of code handling overflow. */
5238 msg = gfc_build_addr_expr (pchar_type_node,
5239 gfc_build_localized_cstring_const
5240 ("Integer overflow when calculating the amount of "
5241 "memory to allocate"));
5242 error = build_call_expr_loc (input_location,
5243 gfor_fndecl_runtime_error, 1, msg);
5245 else
5247 tree status_type = TREE_TYPE (status);
5248 stmtblock_t set_status_block;
5250 gfc_start_block (&set_status_block);
5251 gfc_add_modify (&set_status_block, status,
5252 build_int_cst (status_type, LIBERROR_ALLOCATION));
5253 error = gfc_finish_block (&set_status_block);
5257 gfc_start_block (&elseblock);
5259 /* Allocate memory to store the data. */
5260 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5261 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5263 pointer = gfc_conv_descriptor_data_get (se->expr);
5264 STRIP_NOPS (pointer);
5266 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5267 token = gfc_build_addr_expr (NULL_TREE,
5268 gfc_conv_descriptor_token (se->expr));
5270 /* The allocatable variant takes the old pointer as first argument. */
5271 if (allocatable)
5272 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5273 status, errmsg, errlen, label_finish, expr);
5274 else
5275 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5277 if (dimension)
5279 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5280 boolean_type_node, var_overflow, integer_zero_node));
5281 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5282 error, gfc_finish_block (&elseblock));
5284 else
5285 tmp = gfc_finish_block (&elseblock);
5287 gfc_add_expr_to_block (&se->pre, tmp);
5289 /* Update the array descriptors. */
5290 if (dimension)
5291 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
5293 set_descriptor = gfc_finish_block (&set_descriptor_block);
5294 if (status != NULL_TREE)
5296 cond = fold_build2_loc (input_location, EQ_EXPR,
5297 boolean_type_node, status,
5298 build_int_cst (TREE_TYPE (status), 0));
5299 gfc_add_expr_to_block (&se->pre,
5300 fold_build3_loc (input_location, COND_EXPR, void_type_node,
5301 gfc_likely (cond), set_descriptor,
5302 build_empty_stmt (input_location)));
5304 else
5305 gfc_add_expr_to_block (&se->pre, set_descriptor);
5307 if ((expr->ts.type == BT_DERIVED)
5308 && expr->ts.u.derived->attr.alloc_comp)
5310 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
5311 ref->u.ar.as->rank);
5312 gfc_add_expr_to_block (&se->pre, tmp);
5315 return true;
5319 /* Deallocate an array variable. Also used when an allocated variable goes
5320 out of scope. */
5321 /*GCC ARRAYS*/
5323 tree
5324 gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
5325 tree label_finish, gfc_expr* expr)
5327 tree var;
5328 tree tmp;
5329 stmtblock_t block;
5330 bool coarray = gfc_is_coarray (expr);
5332 gfc_start_block (&block);
5334 /* Get a pointer to the data. */
5335 var = gfc_conv_descriptor_data_get (descriptor);
5336 STRIP_NOPS (var);
5338 /* Parameter is the address of the data component. */
5339 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
5340 errlen, label_finish, false, expr, coarray);
5341 gfc_add_expr_to_block (&block, tmp);
5343 /* Zero the data pointer; only for coarrays an error can occur and then
5344 the allocation status may not be changed. */
5345 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5346 var, build_int_cst (TREE_TYPE (var), 0));
5347 if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5349 tree cond;
5350 tree stat = build_fold_indirect_ref_loc (input_location, pstat);
5352 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5353 stat, build_int_cst (TREE_TYPE (stat), 0));
5354 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5355 cond, tmp, build_empty_stmt (input_location));
5358 gfc_add_expr_to_block (&block, tmp);
5360 return gfc_finish_block (&block);
5364 /* Create an array constructor from an initialization expression.
5365 We assume the frontend already did any expansions and conversions. */
5367 tree
5368 gfc_conv_array_initializer (tree type, gfc_expr * expr)
5370 gfc_constructor *c;
5371 tree tmp;
5372 gfc_se se;
5373 HOST_WIDE_INT hi;
5374 unsigned HOST_WIDE_INT lo;
5375 tree index, range;
5376 vec<constructor_elt, va_gc> *v = NULL;
5378 if (expr->expr_type == EXPR_VARIABLE
5379 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5380 && expr->symtree->n.sym->value)
5381 expr = expr->symtree->n.sym->value;
5383 switch (expr->expr_type)
5385 case EXPR_CONSTANT:
5386 case EXPR_STRUCTURE:
5387 /* A single scalar or derived type value. Create an array with all
5388 elements equal to that value. */
5389 gfc_init_se (&se, NULL);
5391 if (expr->expr_type == EXPR_CONSTANT)
5392 gfc_conv_constant (&se, expr);
5393 else
5394 gfc_conv_structure (&se, expr, 1);
5396 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
5397 gcc_assert (tmp && INTEGER_CST_P (tmp));
5398 hi = TREE_INT_CST_HIGH (tmp);
5399 lo = TREE_INT_CST_LOW (tmp);
5400 lo++;
5401 if (lo == 0)
5402 hi++;
5403 /* This will probably eat buckets of memory for large arrays. */
5404 while (hi != 0 || lo != 0)
5406 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
5407 if (lo == 0)
5408 hi--;
5409 lo--;
5411 break;
5413 case EXPR_ARRAY:
5414 /* Create a vector of all the elements. */
5415 for (c = gfc_constructor_first (expr->value.constructor);
5416 c; c = gfc_constructor_next (c))
5418 if (c->iterator)
5420 /* Problems occur when we get something like
5421 integer :: a(lots) = (/(i, i=1, lots)/) */
5422 gfc_fatal_error ("The number of elements in the array constructor "
5423 "at %L requires an increase of the allowed %d "
5424 "upper limit. See -fmax-array-constructor "
5425 "option", &expr->where,
5426 gfc_option.flag_max_array_constructor);
5427 return NULL_TREE;
5429 if (mpz_cmp_si (c->offset, 0) != 0)
5430 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5431 else
5432 index = NULL_TREE;
5434 if (mpz_cmp_si (c->repeat, 1) > 0)
5436 tree tmp1, tmp2;
5437 mpz_t maxval;
5439 mpz_init (maxval);
5440 mpz_add (maxval, c->offset, c->repeat);
5441 mpz_sub_ui (maxval, maxval, 1);
5442 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5443 if (mpz_cmp_si (c->offset, 0) != 0)
5445 mpz_add_ui (maxval, c->offset, 1);
5446 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5448 else
5449 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5451 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
5452 mpz_clear (maxval);
5454 else
5455 range = NULL;
5457 gfc_init_se (&se, NULL);
5458 switch (c->expr->expr_type)
5460 case EXPR_CONSTANT:
5461 gfc_conv_constant (&se, c->expr);
5462 break;
5464 case EXPR_STRUCTURE:
5465 gfc_conv_structure (&se, c->expr, 1);
5466 break;
5468 default:
5469 /* Catch those occasional beasts that do not simplify
5470 for one reason or another, assuming that if they are
5471 standard defying the frontend will catch them. */
5472 gfc_conv_expr (&se, c->expr);
5473 break;
5476 if (range == NULL_TREE)
5477 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5478 else
5480 if (index != NULL_TREE)
5481 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5482 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
5485 break;
5487 case EXPR_NULL:
5488 return gfc_build_null_descriptor (type);
5490 default:
5491 gcc_unreachable ();
5494 /* Create a constructor from the list of elements. */
5495 tmp = build_constructor (type, v);
5496 TREE_CONSTANT (tmp) = 1;
5497 return tmp;
5501 /* Generate code to evaluate non-constant coarray cobounds. */
5503 void
5504 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
5505 const gfc_symbol *sym)
5507 int dim;
5508 tree ubound;
5509 tree lbound;
5510 gfc_se se;
5511 gfc_array_spec *as;
5513 as = sym->as;
5515 for (dim = as->rank; dim < as->rank + as->corank; dim++)
5517 /* Evaluate non-constant array bound expressions. */
5518 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5519 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5521 gfc_init_se (&se, NULL);
5522 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5523 gfc_add_block_to_block (pblock, &se.pre);
5524 gfc_add_modify (pblock, lbound, se.expr);
5526 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5527 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5529 gfc_init_se (&se, NULL);
5530 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5531 gfc_add_block_to_block (pblock, &se.pre);
5532 gfc_add_modify (pblock, ubound, se.expr);
5538 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5539 returns the size (in elements) of the array. */
5541 static tree
5542 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
5543 stmtblock_t * pblock)
5545 gfc_array_spec *as;
5546 tree size;
5547 tree stride;
5548 tree offset;
5549 tree ubound;
5550 tree lbound;
5551 tree tmp;
5552 gfc_se se;
5554 int dim;
5556 as = sym->as;
5558 size = gfc_index_one_node;
5559 offset = gfc_index_zero_node;
5560 for (dim = 0; dim < as->rank; dim++)
5562 /* Evaluate non-constant array bound expressions. */
5563 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5564 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5566 gfc_init_se (&se, NULL);
5567 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5568 gfc_add_block_to_block (pblock, &se.pre);
5569 gfc_add_modify (pblock, lbound, se.expr);
5571 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5572 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5574 gfc_init_se (&se, NULL);
5575 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5576 gfc_add_block_to_block (pblock, &se.pre);
5577 gfc_add_modify (pblock, ubound, se.expr);
5579 /* The offset of this dimension. offset = offset - lbound * stride. */
5580 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5581 lbound, size);
5582 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5583 offset, tmp);
5585 /* The size of this dimension, and the stride of the next. */
5586 if (dim + 1 < as->rank)
5587 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5588 else
5589 stride = GFC_TYPE_ARRAY_SIZE (type);
5591 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5593 /* Calculate stride = size * (ubound + 1 - lbound). */
5594 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5595 gfc_array_index_type,
5596 gfc_index_one_node, lbound);
5597 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5598 gfc_array_index_type, ubound, tmp);
5599 tmp = fold_build2_loc (input_location, MULT_EXPR,
5600 gfc_array_index_type, size, tmp);
5601 if (stride)
5602 gfc_add_modify (pblock, stride, tmp);
5603 else
5604 stride = gfc_evaluate_now (tmp, pblock);
5606 /* Make sure that negative size arrays are translated
5607 to being zero size. */
5608 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5609 stride, gfc_index_zero_node);
5610 tmp = fold_build3_loc (input_location, COND_EXPR,
5611 gfc_array_index_type, tmp,
5612 stride, gfc_index_zero_node);
5613 gfc_add_modify (pblock, stride, tmp);
5616 size = stride;
5619 gfc_trans_array_cobounds (type, pblock, sym);
5620 gfc_trans_vla_type_sizes (sym, pblock);
5622 *poffset = offset;
5623 return size;
5627 /* Generate code to initialize/allocate an array variable. */
5629 void
5630 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5631 gfc_wrapped_block * block)
5633 stmtblock_t init;
5634 tree type;
5635 tree tmp = NULL_TREE;
5636 tree size;
5637 tree offset;
5638 tree space;
5639 tree inittree;
5640 bool onstack;
5642 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5644 /* Do nothing for USEd variables. */
5645 if (sym->attr.use_assoc)
5646 return;
5648 type = TREE_TYPE (decl);
5649 gcc_assert (GFC_ARRAY_TYPE_P (type));
5650 onstack = TREE_CODE (type) != POINTER_TYPE;
5652 gfc_init_block (&init);
5654 /* Evaluate character string length. */
5655 if (sym->ts.type == BT_CHARACTER
5656 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5658 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5660 gfc_trans_vla_type_sizes (sym, &init);
5662 /* Emit a DECL_EXPR for this variable, which will cause the
5663 gimplifier to allocate storage, and all that good stuff. */
5664 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5665 gfc_add_expr_to_block (&init, tmp);
5668 if (onstack)
5670 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5671 return;
5674 type = TREE_TYPE (type);
5676 gcc_assert (!sym->attr.use_assoc);
5677 gcc_assert (!TREE_STATIC (decl));
5678 gcc_assert (!sym->module);
5680 if (sym->ts.type == BT_CHARACTER
5681 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5682 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5684 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5686 /* Don't actually allocate space for Cray Pointees. */
5687 if (sym->attr.cray_pointee)
5689 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5690 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5692 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5693 return;
5696 if (gfc_option.flag_stack_arrays)
5698 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5699 space = build_decl (sym->declared_at.lb->location,
5700 VAR_DECL, create_tmp_var_name ("A"),
5701 TREE_TYPE (TREE_TYPE (decl)));
5702 gfc_trans_vla_type_sizes (sym, &init);
5704 else
5706 /* The size is the number of elements in the array, so multiply by the
5707 size of an element to get the total size. */
5708 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5709 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5710 size, fold_convert (gfc_array_index_type, tmp));
5712 /* Allocate memory to hold the data. */
5713 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5714 gfc_add_modify (&init, decl, tmp);
5716 /* Free the temporary. */
5717 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5718 space = NULL_TREE;
5721 /* Set offset of the array. */
5722 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5723 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5725 /* Automatic arrays should not have initializers. */
5726 gcc_assert (!sym->value);
5728 inittree = gfc_finish_block (&init);
5730 if (space)
5732 tree addr;
5733 pushdecl (space);
5735 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5736 where also space is located. */
5737 gfc_init_block (&init);
5738 tmp = fold_build1_loc (input_location, DECL_EXPR,
5739 TREE_TYPE (space), space);
5740 gfc_add_expr_to_block (&init, tmp);
5741 addr = fold_build1_loc (sym->declared_at.lb->location,
5742 ADDR_EXPR, TREE_TYPE (decl), space);
5743 gfc_add_modify (&init, decl, addr);
5744 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5745 tmp = NULL_TREE;
5747 gfc_add_init_cleanup (block, inittree, tmp);
5751 /* Generate entry and exit code for g77 calling convention arrays. */
5753 void
5754 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5756 tree parm;
5757 tree type;
5758 locus loc;
5759 tree offset;
5760 tree tmp;
5761 tree stmt;
5762 stmtblock_t init;
5764 gfc_save_backend_locus (&loc);
5765 gfc_set_backend_locus (&sym->declared_at);
5767 /* Descriptor type. */
5768 parm = sym->backend_decl;
5769 type = TREE_TYPE (parm);
5770 gcc_assert (GFC_ARRAY_TYPE_P (type));
5772 gfc_start_block (&init);
5774 if (sym->ts.type == BT_CHARACTER
5775 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5776 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5778 /* Evaluate the bounds of the array. */
5779 gfc_trans_array_bounds (type, sym, &offset, &init);
5781 /* Set the offset. */
5782 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5783 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5785 /* Set the pointer itself if we aren't using the parameter directly. */
5786 if (TREE_CODE (parm) != PARM_DECL)
5788 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5789 gfc_add_modify (&init, parm, tmp);
5791 stmt = gfc_finish_block (&init);
5793 gfc_restore_backend_locus (&loc);
5795 /* Add the initialization code to the start of the function. */
5797 if (sym->attr.optional || sym->attr.not_always_present)
5799 tmp = gfc_conv_expr_present (sym);
5800 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5803 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5807 /* Modify the descriptor of an array parameter so that it has the
5808 correct lower bound. Also move the upper bound accordingly.
5809 If the array is not packed, it will be copied into a temporary.
5810 For each dimension we set the new lower and upper bounds. Then we copy the
5811 stride and calculate the offset for this dimension. We also work out
5812 what the stride of a packed array would be, and see it the two match.
5813 If the array need repacking, we set the stride to the values we just
5814 calculated, recalculate the offset and copy the array data.
5815 Code is also added to copy the data back at the end of the function.
5818 void
5819 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5820 gfc_wrapped_block * block)
5822 tree size;
5823 tree type;
5824 tree offset;
5825 locus loc;
5826 stmtblock_t init;
5827 tree stmtInit, stmtCleanup;
5828 tree lbound;
5829 tree ubound;
5830 tree dubound;
5831 tree dlbound;
5832 tree dumdesc;
5833 tree tmp;
5834 tree stride, stride2;
5835 tree stmt_packed;
5836 tree stmt_unpacked;
5837 tree partial;
5838 gfc_se se;
5839 int n;
5840 int checkparm;
5841 int no_repack;
5842 bool optional_arg;
5844 /* Do nothing for pointer and allocatable arrays. */
5845 if (sym->attr.pointer || sym->attr.allocatable)
5846 return;
5848 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5850 gfc_trans_g77_array (sym, block);
5851 return;
5854 gfc_save_backend_locus (&loc);
5855 gfc_set_backend_locus (&sym->declared_at);
5857 /* Descriptor type. */
5858 type = TREE_TYPE (tmpdesc);
5859 gcc_assert (GFC_ARRAY_TYPE_P (type));
5860 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5861 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5862 gfc_start_block (&init);
5864 if (sym->ts.type == BT_CHARACTER
5865 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5866 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5868 checkparm = (sym->as->type == AS_EXPLICIT
5869 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5871 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5872 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5874 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5876 /* For non-constant shape arrays we only check if the first dimension
5877 is contiguous. Repacking higher dimensions wouldn't gain us
5878 anything as we still don't know the array stride. */
5879 partial = gfc_create_var (boolean_type_node, "partial");
5880 TREE_USED (partial) = 1;
5881 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5882 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5883 gfc_index_one_node);
5884 gfc_add_modify (&init, partial, tmp);
5886 else
5887 partial = NULL_TREE;
5889 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5890 here, however I think it does the right thing. */
5891 if (no_repack)
5893 /* Set the first stride. */
5894 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5895 stride = gfc_evaluate_now (stride, &init);
5897 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5898 stride, gfc_index_zero_node);
5899 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5900 tmp, gfc_index_one_node, stride);
5901 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5902 gfc_add_modify (&init, stride, tmp);
5904 /* Allow the user to disable array repacking. */
5905 stmt_unpacked = NULL_TREE;
5907 else
5909 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5910 /* A library call to repack the array if necessary. */
5911 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5912 stmt_unpacked = build_call_expr_loc (input_location,
5913 gfor_fndecl_in_pack, 1, tmp);
5915 stride = gfc_index_one_node;
5917 if (gfc_option.warn_array_temp)
5918 gfc_warning ("Creating array temporary at %L", &loc);
5921 /* This is for the case where the array data is used directly without
5922 calling the repack function. */
5923 if (no_repack || partial != NULL_TREE)
5924 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5925 else
5926 stmt_packed = NULL_TREE;
5928 /* Assign the data pointer. */
5929 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5931 /* Don't repack unknown shape arrays when the first stride is 1. */
5932 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5933 partial, stmt_packed, stmt_unpacked);
5935 else
5936 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5937 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5939 offset = gfc_index_zero_node;
5940 size = gfc_index_one_node;
5942 /* Evaluate the bounds of the array. */
5943 for (n = 0; n < sym->as->rank; n++)
5945 if (checkparm || !sym->as->upper[n])
5947 /* Get the bounds of the actual parameter. */
5948 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5949 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5951 else
5953 dubound = NULL_TREE;
5954 dlbound = NULL_TREE;
5957 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5958 if (!INTEGER_CST_P (lbound))
5960 gfc_init_se (&se, NULL);
5961 gfc_conv_expr_type (&se, sym->as->lower[n],
5962 gfc_array_index_type);
5963 gfc_add_block_to_block (&init, &se.pre);
5964 gfc_add_modify (&init, lbound, se.expr);
5967 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5968 /* Set the desired upper bound. */
5969 if (sym->as->upper[n])
5971 /* We know what we want the upper bound to be. */
5972 if (!INTEGER_CST_P (ubound))
5974 gfc_init_se (&se, NULL);
5975 gfc_conv_expr_type (&se, sym->as->upper[n],
5976 gfc_array_index_type);
5977 gfc_add_block_to_block (&init, &se.pre);
5978 gfc_add_modify (&init, ubound, se.expr);
5981 /* Check the sizes match. */
5982 if (checkparm)
5984 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5985 char * msg;
5986 tree temp;
5988 temp = fold_build2_loc (input_location, MINUS_EXPR,
5989 gfc_array_index_type, ubound, lbound);
5990 temp = fold_build2_loc (input_location, PLUS_EXPR,
5991 gfc_array_index_type,
5992 gfc_index_one_node, temp);
5993 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
5994 gfc_array_index_type, dubound,
5995 dlbound);
5996 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
5997 gfc_array_index_type,
5998 gfc_index_one_node, stride2);
5999 tmp = fold_build2_loc (input_location, NE_EXPR,
6000 gfc_array_index_type, temp, stride2);
6001 asprintf (&msg, "Dimension %d of array '%s' has extent "
6002 "%%ld instead of %%ld", n+1, sym->name);
6004 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
6005 fold_convert (long_integer_type_node, temp),
6006 fold_convert (long_integer_type_node, stride2));
6008 free (msg);
6011 else
6013 /* For assumed shape arrays move the upper bound by the same amount
6014 as the lower bound. */
6015 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6016 gfc_array_index_type, dubound, dlbound);
6017 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6018 gfc_array_index_type, tmp, lbound);
6019 gfc_add_modify (&init, ubound, tmp);
6021 /* The offset of this dimension. offset = offset - lbound * stride. */
6022 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6023 lbound, stride);
6024 offset = fold_build2_loc (input_location, MINUS_EXPR,
6025 gfc_array_index_type, offset, tmp);
6027 /* The size of this dimension, and the stride of the next. */
6028 if (n + 1 < sym->as->rank)
6030 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
6032 if (no_repack || partial != NULL_TREE)
6033 stmt_unpacked =
6034 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
6036 /* Figure out the stride if not a known constant. */
6037 if (!INTEGER_CST_P (stride))
6039 if (no_repack)
6040 stmt_packed = NULL_TREE;
6041 else
6043 /* Calculate stride = size * (ubound + 1 - lbound). */
6044 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6045 gfc_array_index_type,
6046 gfc_index_one_node, lbound);
6047 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6048 gfc_array_index_type, ubound, tmp);
6049 size = fold_build2_loc (input_location, MULT_EXPR,
6050 gfc_array_index_type, size, tmp);
6051 stmt_packed = size;
6054 /* Assign the stride. */
6055 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6056 tmp = fold_build3_loc (input_location, COND_EXPR,
6057 gfc_array_index_type, partial,
6058 stmt_unpacked, stmt_packed);
6059 else
6060 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
6061 gfc_add_modify (&init, stride, tmp);
6064 else
6066 stride = GFC_TYPE_ARRAY_SIZE (type);
6068 if (stride && !INTEGER_CST_P (stride))
6070 /* Calculate size = stride * (ubound + 1 - lbound). */
6071 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6072 gfc_array_index_type,
6073 gfc_index_one_node, lbound);
6074 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6075 gfc_array_index_type,
6076 ubound, tmp);
6077 tmp = fold_build2_loc (input_location, MULT_EXPR,
6078 gfc_array_index_type,
6079 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
6080 gfc_add_modify (&init, stride, tmp);
6085 gfc_trans_array_cobounds (type, &init, sym);
6087 /* Set the offset. */
6088 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
6089 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6091 gfc_trans_vla_type_sizes (sym, &init);
6093 stmtInit = gfc_finish_block (&init);
6095 /* Only do the entry/initialization code if the arg is present. */
6096 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6097 optional_arg = (sym->attr.optional
6098 || (sym->ns->proc_name->attr.entry_master
6099 && sym->attr.dummy));
6100 if (optional_arg)
6102 tmp = gfc_conv_expr_present (sym);
6103 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
6104 build_empty_stmt (input_location));
6107 /* Cleanup code. */
6108 if (no_repack)
6109 stmtCleanup = NULL_TREE;
6110 else
6112 stmtblock_t cleanup;
6113 gfc_start_block (&cleanup);
6115 if (sym->attr.intent != INTENT_IN)
6117 /* Copy the data back. */
6118 tmp = build_call_expr_loc (input_location,
6119 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
6120 gfc_add_expr_to_block (&cleanup, tmp);
6123 /* Free the temporary. */
6124 tmp = gfc_call_free (tmpdesc);
6125 gfc_add_expr_to_block (&cleanup, tmp);
6127 stmtCleanup = gfc_finish_block (&cleanup);
6129 /* Only do the cleanup if the array was repacked. */
6130 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
6131 tmp = gfc_conv_descriptor_data_get (tmp);
6132 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6133 tmp, tmpdesc);
6134 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6135 build_empty_stmt (input_location));
6137 if (optional_arg)
6139 tmp = gfc_conv_expr_present (sym);
6140 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6141 build_empty_stmt (input_location));
6145 /* We don't need to free any memory allocated by internal_pack as it will
6146 be freed at the end of the function by pop_context. */
6147 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
6149 gfc_restore_backend_locus (&loc);
6153 /* Calculate the overall offset, including subreferences. */
6154 static void
6155 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
6156 bool subref, gfc_expr *expr)
6158 tree tmp;
6159 tree field;
6160 tree stride;
6161 tree index;
6162 gfc_ref *ref;
6163 gfc_se start;
6164 int n;
6166 /* If offset is NULL and this is not a subreferenced array, there is
6167 nothing to do. */
6168 if (offset == NULL_TREE)
6170 if (subref)
6171 offset = gfc_index_zero_node;
6172 else
6173 return;
6176 tmp = build_array_ref (desc, offset, NULL);
6178 /* Offset the data pointer for pointer assignments from arrays with
6179 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6180 if (subref)
6182 /* Go past the array reference. */
6183 for (ref = expr->ref; ref; ref = ref->next)
6184 if (ref->type == REF_ARRAY &&
6185 ref->u.ar.type != AR_ELEMENT)
6187 ref = ref->next;
6188 break;
6191 /* Calculate the offset for each subsequent subreference. */
6192 for (; ref; ref = ref->next)
6194 switch (ref->type)
6196 case REF_COMPONENT:
6197 field = ref->u.c.component->backend_decl;
6198 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6199 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6200 TREE_TYPE (field),
6201 tmp, field, NULL_TREE);
6202 break;
6204 case REF_SUBSTRING:
6205 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6206 gfc_init_se (&start, NULL);
6207 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6208 gfc_add_block_to_block (block, &start.pre);
6209 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6210 break;
6212 case REF_ARRAY:
6213 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6214 && ref->u.ar.type == AR_ELEMENT);
6216 /* TODO - Add bounds checking. */
6217 stride = gfc_index_one_node;
6218 index = gfc_index_zero_node;
6219 for (n = 0; n < ref->u.ar.dimen; n++)
6221 tree itmp;
6222 tree jtmp;
6224 /* Update the index. */
6225 gfc_init_se (&start, NULL);
6226 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6227 itmp = gfc_evaluate_now (start.expr, block);
6228 gfc_init_se (&start, NULL);
6229 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6230 jtmp = gfc_evaluate_now (start.expr, block);
6231 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6232 gfc_array_index_type, itmp, jtmp);
6233 itmp = fold_build2_loc (input_location, MULT_EXPR,
6234 gfc_array_index_type, itmp, stride);
6235 index = fold_build2_loc (input_location, PLUS_EXPR,
6236 gfc_array_index_type, itmp, index);
6237 index = gfc_evaluate_now (index, block);
6239 /* Update the stride. */
6240 gfc_init_se (&start, NULL);
6241 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6242 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6243 gfc_array_index_type, start.expr,
6244 jtmp);
6245 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6246 gfc_array_index_type,
6247 gfc_index_one_node, itmp);
6248 stride = fold_build2_loc (input_location, MULT_EXPR,
6249 gfc_array_index_type, stride, itmp);
6250 stride = gfc_evaluate_now (stride, block);
6253 /* Apply the index to obtain the array element. */
6254 tmp = gfc_build_array_ref (tmp, index, NULL);
6255 break;
6257 default:
6258 gcc_unreachable ();
6259 break;
6264 /* Set the target data pointer. */
6265 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6266 gfc_conv_descriptor_data_set (block, parm, offset);
6270 /* gfc_conv_expr_descriptor needs the string length an expression
6271 so that the size of the temporary can be obtained. This is done
6272 by adding up the string lengths of all the elements in the
6273 expression. Function with non-constant expressions have their
6274 string lengths mapped onto the actual arguments using the
6275 interface mapping machinery in trans-expr.c. */
6276 static void
6277 get_array_charlen (gfc_expr *expr, gfc_se *se)
6279 gfc_interface_mapping mapping;
6280 gfc_formal_arglist *formal;
6281 gfc_actual_arglist *arg;
6282 gfc_se tse;
6284 if (expr->ts.u.cl->length
6285 && gfc_is_constant_expr (expr->ts.u.cl->length))
6287 if (!expr->ts.u.cl->backend_decl)
6288 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6289 return;
6292 switch (expr->expr_type)
6294 case EXPR_OP:
6295 get_array_charlen (expr->value.op.op1, se);
6297 /* For parentheses the expression ts.u.cl is identical. */
6298 if (expr->value.op.op == INTRINSIC_PARENTHESES)
6299 return;
6301 expr->ts.u.cl->backend_decl =
6302 gfc_create_var (gfc_charlen_type_node, "sln");
6304 if (expr->value.op.op2)
6306 get_array_charlen (expr->value.op.op2, se);
6308 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
6310 /* Add the string lengths and assign them to the expression
6311 string length backend declaration. */
6312 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6313 fold_build2_loc (input_location, PLUS_EXPR,
6314 gfc_charlen_type_node,
6315 expr->value.op.op1->ts.u.cl->backend_decl,
6316 expr->value.op.op2->ts.u.cl->backend_decl));
6318 else
6319 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6320 expr->value.op.op1->ts.u.cl->backend_decl);
6321 break;
6323 case EXPR_FUNCTION:
6324 if (expr->value.function.esym == NULL
6325 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6327 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6328 break;
6331 /* Map expressions involving the dummy arguments onto the actual
6332 argument expressions. */
6333 gfc_init_interface_mapping (&mapping);
6334 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
6335 arg = expr->value.function.actual;
6337 /* Set se = NULL in the calls to the interface mapping, to suppress any
6338 backend stuff. */
6339 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
6341 if (!arg->expr)
6342 continue;
6343 if (formal->sym)
6344 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
6347 gfc_init_se (&tse, NULL);
6349 /* Build the expression for the character length and convert it. */
6350 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
6352 gfc_add_block_to_block (&se->pre, &tse.pre);
6353 gfc_add_block_to_block (&se->post, &tse.post);
6354 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
6355 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
6356 gfc_charlen_type_node, tse.expr,
6357 build_int_cst (gfc_charlen_type_node, 0));
6358 expr->ts.u.cl->backend_decl = tse.expr;
6359 gfc_free_interface_mapping (&mapping);
6360 break;
6362 default:
6363 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6364 break;
6369 /* Helper function to check dimensions. */
6370 static bool
6371 transposed_dims (gfc_ss *ss)
6373 int n;
6375 for (n = 0; n < ss->dimen; n++)
6376 if (ss->dim[n] != n)
6377 return true;
6378 return false;
6382 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6383 AR_FULL, suitable for the scalarizer. */
6385 static gfc_ss *
6386 walk_coarray (gfc_expr *e)
6388 gfc_ss *ss;
6390 gcc_assert (gfc_get_corank (e) > 0);
6392 ss = gfc_walk_expr (e);
6394 /* Fix scalar coarray. */
6395 if (ss == gfc_ss_terminator)
6397 gfc_ref *ref;
6399 ref = e->ref;
6400 while (ref)
6402 if (ref->type == REF_ARRAY
6403 && ref->u.ar.codimen > 0)
6404 break;
6406 ref = ref->next;
6409 gcc_assert (ref != NULL);
6410 if (ref->u.ar.type == AR_ELEMENT)
6411 ref->u.ar.type = AR_SECTION;
6412 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
6415 return ss;
6419 /* Convert an array for passing as an actual argument. Expressions and
6420 vector subscripts are evaluated and stored in a temporary, which is then
6421 passed. For whole arrays the descriptor is passed. For array sections
6422 a modified copy of the descriptor is passed, but using the original data.
6424 This function is also used for array pointer assignments, and there
6425 are three cases:
6427 - se->want_pointer && !se->direct_byref
6428 EXPR is an actual argument. On exit, se->expr contains a
6429 pointer to the array descriptor.
6431 - !se->want_pointer && !se->direct_byref
6432 EXPR is an actual argument to an intrinsic function or the
6433 left-hand side of a pointer assignment. On exit, se->expr
6434 contains the descriptor for EXPR.
6436 - !se->want_pointer && se->direct_byref
6437 EXPR is the right-hand side of a pointer assignment and
6438 se->expr is the descriptor for the previously-evaluated
6439 left-hand side. The function creates an assignment from
6440 EXPR to se->expr.
6443 The se->force_tmp flag disables the non-copying descriptor optimization
6444 that is used for transpose. It may be used in cases where there is an
6445 alias between the transpose argument and another argument in the same
6446 function call. */
6448 void
6449 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
6451 gfc_ss *ss;
6452 gfc_ss_type ss_type;
6453 gfc_ss_info *ss_info;
6454 gfc_loopinfo loop;
6455 gfc_array_info *info;
6456 int need_tmp;
6457 int n;
6458 tree tmp;
6459 tree desc;
6460 stmtblock_t block;
6461 tree start;
6462 tree offset;
6463 int full;
6464 bool subref_array_target = false;
6465 gfc_expr *arg, *ss_expr;
6467 if (se->want_coarray)
6468 ss = walk_coarray (expr);
6469 else
6470 ss = gfc_walk_expr (expr);
6472 gcc_assert (ss != NULL);
6473 gcc_assert (ss != gfc_ss_terminator);
6475 ss_info = ss->info;
6476 ss_type = ss_info->type;
6477 ss_expr = ss_info->expr;
6479 /* Special case: TRANSPOSE which needs no temporary. */
6480 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
6481 && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
6483 /* This is a call to transpose which has already been handled by the
6484 scalarizer, so that we just need to get its argument's descriptor. */
6485 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6486 expr = expr->value.function.actual->expr;
6489 /* Special case things we know we can pass easily. */
6490 switch (expr->expr_type)
6492 case EXPR_VARIABLE:
6493 /* If we have a linear array section, we can pass it directly.
6494 Otherwise we need to copy it into a temporary. */
6496 gcc_assert (ss_type == GFC_SS_SECTION);
6497 gcc_assert (ss_expr == expr);
6498 info = &ss_info->data.array;
6500 /* Get the descriptor for the array. */
6501 gfc_conv_ss_descriptor (&se->pre, ss, 0);
6502 desc = info->descriptor;
6504 subref_array_target = se->direct_byref && is_subref_array (expr);
6505 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
6506 && !subref_array_target;
6508 if (se->force_tmp)
6509 need_tmp = 1;
6511 if (need_tmp)
6512 full = 0;
6513 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6515 /* Create a new descriptor if the array doesn't have one. */
6516 full = 0;
6518 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
6519 full = 1;
6520 else if (se->direct_byref)
6521 full = 0;
6522 else
6523 full = gfc_full_array_ref_p (info->ref, NULL);
6525 if (full && !transposed_dims (ss))
6527 if (se->direct_byref && !se->byref_noassign)
6529 /* Copy the descriptor for pointer assignments. */
6530 gfc_add_modify (&se->pre, se->expr, desc);
6532 /* Add any offsets from subreferences. */
6533 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
6534 subref_array_target, expr);
6536 else if (se->want_pointer)
6538 /* We pass full arrays directly. This means that pointers and
6539 allocatable arrays should also work. */
6540 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6542 else
6544 se->expr = desc;
6547 if (expr->ts.type == BT_CHARACTER)
6548 se->string_length = gfc_get_expr_charlen (expr);
6550 gfc_free_ss_chain (ss);
6551 return;
6553 break;
6555 case EXPR_FUNCTION:
6556 /* A transformational function return value will be a temporary
6557 array descriptor. We still need to go through the scalarizer
6558 to create the descriptor. Elemental functions are handled as
6559 arbitrary expressions, i.e. copy to a temporary. */
6561 if (se->direct_byref)
6563 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
6565 /* For pointer assignments pass the descriptor directly. */
6566 if (se->ss == NULL)
6567 se->ss = ss;
6568 else
6569 gcc_assert (se->ss == ss);
6570 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6571 gfc_conv_expr (se, expr);
6572 gfc_free_ss_chain (ss);
6573 return;
6576 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
6578 if (ss_expr != expr)
6579 /* Elemental function. */
6580 gcc_assert ((expr->value.function.esym != NULL
6581 && expr->value.function.esym->attr.elemental)
6582 || (expr->value.function.isym != NULL
6583 && expr->value.function.isym->elemental)
6584 || gfc_inline_intrinsic_function_p (expr));
6585 else
6586 gcc_assert (ss_type == GFC_SS_INTRINSIC);
6588 need_tmp = 1;
6589 if (expr->ts.type == BT_CHARACTER
6590 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6591 get_array_charlen (expr, se);
6593 info = NULL;
6595 else
6597 /* Transformational function. */
6598 info = &ss_info->data.array;
6599 need_tmp = 0;
6601 break;
6603 case EXPR_ARRAY:
6604 /* Constant array constructors don't need a temporary. */
6605 if (ss_type == GFC_SS_CONSTRUCTOR
6606 && expr->ts.type != BT_CHARACTER
6607 && gfc_constant_array_constructor_p (expr->value.constructor))
6609 need_tmp = 0;
6610 info = &ss_info->data.array;
6612 else
6614 need_tmp = 1;
6615 info = NULL;
6617 break;
6619 default:
6620 /* Something complicated. Copy it into a temporary. */
6621 need_tmp = 1;
6622 info = NULL;
6623 break;
6626 /* If we are creating a temporary, we don't need to bother about aliases
6627 anymore. */
6628 if (need_tmp)
6629 se->force_tmp = 0;
6631 gfc_init_loopinfo (&loop);
6633 /* Associate the SS with the loop. */
6634 gfc_add_ss_to_loop (&loop, ss);
6636 /* Tell the scalarizer not to bother creating loop variables, etc. */
6637 if (!need_tmp)
6638 loop.array_parameter = 1;
6639 else
6640 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6641 gcc_assert (!se->direct_byref);
6643 /* Setup the scalarizing loops and bounds. */
6644 gfc_conv_ss_startstride (&loop);
6646 if (need_tmp)
6648 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6649 get_array_charlen (expr, se);
6651 /* Tell the scalarizer to make a temporary. */
6652 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6653 ((expr->ts.type == BT_CHARACTER)
6654 ? expr->ts.u.cl->backend_decl
6655 : NULL),
6656 loop.dimen);
6658 se->string_length = loop.temp_ss->info->string_length;
6659 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6660 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6663 gfc_conv_loop_setup (&loop, & expr->where);
6665 if (need_tmp)
6667 /* Copy into a temporary and pass that. We don't need to copy the data
6668 back because expressions and vector subscripts must be INTENT_IN. */
6669 /* TODO: Optimize passing function return values. */
6670 gfc_se lse;
6671 gfc_se rse;
6673 /* Start the copying loops. */
6674 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6675 gfc_mark_ss_chain_used (ss, 1);
6676 gfc_start_scalarized_body (&loop, &block);
6678 /* Copy each data element. */
6679 gfc_init_se (&lse, NULL);
6680 gfc_copy_loopinfo_to_se (&lse, &loop);
6681 gfc_init_se (&rse, NULL);
6682 gfc_copy_loopinfo_to_se (&rse, &loop);
6684 lse.ss = loop.temp_ss;
6685 rse.ss = ss;
6687 gfc_conv_scalarized_array_ref (&lse, NULL);
6688 if (expr->ts.type == BT_CHARACTER)
6690 gfc_conv_expr (&rse, expr);
6691 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6692 rse.expr = build_fold_indirect_ref_loc (input_location,
6693 rse.expr);
6695 else
6696 gfc_conv_expr_val (&rse, expr);
6698 gfc_add_block_to_block (&block, &rse.pre);
6699 gfc_add_block_to_block (&block, &lse.pre);
6701 lse.string_length = rse.string_length;
6702 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6703 expr->expr_type == EXPR_VARIABLE
6704 || expr->expr_type == EXPR_ARRAY, true);
6705 gfc_add_expr_to_block (&block, tmp);
6707 /* Finish the copying loops. */
6708 gfc_trans_scalarizing_loops (&loop, &block);
6710 desc = loop.temp_ss->info->data.array.descriptor;
6712 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6714 desc = info->descriptor;
6715 se->string_length = ss_info->string_length;
6717 else
6719 /* We pass sections without copying to a temporary. Make a new
6720 descriptor and point it at the section we want. The loop variable
6721 limits will be the limits of the section.
6722 A function may decide to repack the array to speed up access, but
6723 we're not bothered about that here. */
6724 int dim, ndim, codim;
6725 tree parm;
6726 tree parmtype;
6727 tree stride;
6728 tree from;
6729 tree to;
6730 tree base;
6732 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6734 if (se->want_coarray)
6736 gfc_array_ref *ar = &info->ref->u.ar;
6738 codim = gfc_get_corank (expr);
6739 for (n = 0; n < codim - 1; n++)
6741 /* Make sure we are not lost somehow. */
6742 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6744 /* Make sure the call to gfc_conv_section_startstride won't
6745 generate unnecessary code to calculate stride. */
6746 gcc_assert (ar->stride[n + ndim] == NULL);
6748 gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
6749 loop.from[n + loop.dimen] = info->start[n + ndim];
6750 loop.to[n + loop.dimen] = info->end[n + ndim];
6753 gcc_assert (n == codim - 1);
6754 evaluate_bound (&loop.pre, info->start, ar->start,
6755 info->descriptor, n + ndim, true);
6756 loop.from[n + loop.dimen] = info->start[n + ndim];
6758 else
6759 codim = 0;
6761 /* Set the string_length for a character array. */
6762 if (expr->ts.type == BT_CHARACTER)
6763 se->string_length = gfc_get_expr_charlen (expr);
6765 desc = info->descriptor;
6766 if (se->direct_byref && !se->byref_noassign)
6768 /* For pointer assignments we fill in the destination. */
6769 parm = se->expr;
6770 parmtype = TREE_TYPE (parm);
6772 else
6774 /* Otherwise make a new one. */
6775 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6776 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6777 loop.from, loop.to, 0,
6778 GFC_ARRAY_UNKNOWN, false);
6779 parm = gfc_create_var (parmtype, "parm");
6782 offset = gfc_index_zero_node;
6784 /* The following can be somewhat confusing. We have two
6785 descriptors, a new one and the original array.
6786 {parm, parmtype, dim} refer to the new one.
6787 {desc, type, n, loop} refer to the original, which maybe
6788 a descriptorless array.
6789 The bounds of the scalarization are the bounds of the section.
6790 We don't have to worry about numeric overflows when calculating
6791 the offsets because all elements are within the array data. */
6793 /* Set the dtype. */
6794 tmp = gfc_conv_descriptor_dtype (parm);
6795 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6797 /* Set offset for assignments to pointer only to zero if it is not
6798 the full array. */
6799 if (se->direct_byref
6800 && info->ref && info->ref->u.ar.type != AR_FULL)
6801 base = gfc_index_zero_node;
6802 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6803 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6804 else
6805 base = NULL_TREE;
6807 for (n = 0; n < ndim; n++)
6809 stride = gfc_conv_array_stride (desc, n);
6811 /* Work out the offset. */
6812 if (info->ref
6813 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6815 gcc_assert (info->subscript[n]
6816 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6817 start = info->subscript[n]->info->data.scalar.value;
6819 else
6821 /* Evaluate and remember the start of the section. */
6822 start = info->start[n];
6823 stride = gfc_evaluate_now (stride, &loop.pre);
6826 tmp = gfc_conv_array_lbound (desc, n);
6827 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6828 start, tmp);
6829 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6830 tmp, stride);
6831 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6832 offset, tmp);
6834 if (info->ref
6835 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6837 /* For elemental dimensions, we only need the offset. */
6838 continue;
6841 /* Vector subscripts need copying and are handled elsewhere. */
6842 if (info->ref)
6843 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6845 /* look for the corresponding scalarizer dimension: dim. */
6846 for (dim = 0; dim < ndim; dim++)
6847 if (ss->dim[dim] == n)
6848 break;
6850 /* loop exited early: the DIM being looked for has been found. */
6851 gcc_assert (dim < ndim);
6853 /* Set the new lower bound. */
6854 from = loop.from[dim];
6855 to = loop.to[dim];
6857 /* If we have an array section or are assigning make sure that
6858 the lower bound is 1. References to the full
6859 array should otherwise keep the original bounds. */
6860 if ((!info->ref
6861 || info->ref->u.ar.type != AR_FULL)
6862 && !integer_onep (from))
6864 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6865 gfc_array_index_type, gfc_index_one_node,
6866 from);
6867 to = fold_build2_loc (input_location, PLUS_EXPR,
6868 gfc_array_index_type, to, tmp);
6869 from = gfc_index_one_node;
6871 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6872 gfc_rank_cst[dim], from);
6874 /* Set the new upper bound. */
6875 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6876 gfc_rank_cst[dim], to);
6878 /* Multiply the stride by the section stride to get the
6879 total stride. */
6880 stride = fold_build2_loc (input_location, MULT_EXPR,
6881 gfc_array_index_type,
6882 stride, info->stride[n]);
6884 if (se->direct_byref
6885 && info->ref
6886 && info->ref->u.ar.type != AR_FULL)
6888 base = fold_build2_loc (input_location, MINUS_EXPR,
6889 TREE_TYPE (base), base, stride);
6891 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6893 tmp = gfc_conv_array_lbound (desc, n);
6894 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6895 TREE_TYPE (base), tmp, loop.from[dim]);
6896 tmp = fold_build2_loc (input_location, MULT_EXPR,
6897 TREE_TYPE (base), tmp,
6898 gfc_conv_array_stride (desc, n));
6899 base = fold_build2_loc (input_location, PLUS_EXPR,
6900 TREE_TYPE (base), tmp, base);
6903 /* Store the new stride. */
6904 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6905 gfc_rank_cst[dim], stride);
6908 for (n = loop.dimen; n < loop.dimen + codim; n++)
6910 from = loop.from[n];
6911 to = loop.to[n];
6912 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6913 gfc_rank_cst[n], from);
6914 if (n < loop.dimen + codim - 1)
6915 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6916 gfc_rank_cst[n], to);
6919 if (se->data_not_needed)
6920 gfc_conv_descriptor_data_set (&loop.pre, parm,
6921 gfc_index_zero_node);
6922 else
6923 /* Point the data pointer at the 1st element in the section. */
6924 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6925 subref_array_target, expr);
6927 if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6928 && !se->data_not_needed)
6930 /* Set the offset. */
6931 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6933 else
6935 /* Only the callee knows what the correct offset it, so just set
6936 it to zero here. */
6937 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6939 desc = parm;
6942 if (!se->direct_byref || se->byref_noassign)
6944 /* Get a pointer to the new descriptor. */
6945 if (se->want_pointer)
6946 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6947 else
6948 se->expr = desc;
6951 gfc_add_block_to_block (&se->pre, &loop.pre);
6952 gfc_add_block_to_block (&se->post, &loop.post);
6954 /* Cleanup the scalarizer. */
6955 gfc_cleanup_loop (&loop);
6958 /* Helper function for gfc_conv_array_parameter if array size needs to be
6959 computed. */
6961 static void
6962 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6964 tree elem;
6965 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6966 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6967 else if (expr->rank > 1)
6968 *size = build_call_expr_loc (input_location,
6969 gfor_fndecl_size0, 1,
6970 gfc_build_addr_expr (NULL, desc));
6971 else
6973 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6974 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6976 *size = fold_build2_loc (input_location, MINUS_EXPR,
6977 gfc_array_index_type, ubound, lbound);
6978 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6979 *size, gfc_index_one_node);
6980 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6981 *size, gfc_index_zero_node);
6983 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6984 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6985 *size, fold_convert (gfc_array_index_type, elem));
6988 /* Convert an array for passing as an actual parameter. */
6989 /* TODO: Optimize passing g77 arrays. */
6991 void
6992 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
6993 const gfc_symbol *fsym, const char *proc_name,
6994 tree *size)
6996 tree ptr;
6997 tree desc;
6998 tree tmp = NULL_TREE;
6999 tree stmt;
7000 tree parent = DECL_CONTEXT (current_function_decl);
7001 bool full_array_var;
7002 bool this_array_result;
7003 bool contiguous;
7004 bool no_pack;
7005 bool array_constructor;
7006 bool good_allocatable;
7007 bool ultimate_ptr_comp;
7008 bool ultimate_alloc_comp;
7009 gfc_symbol *sym;
7010 stmtblock_t block;
7011 gfc_ref *ref;
7013 ultimate_ptr_comp = false;
7014 ultimate_alloc_comp = false;
7016 for (ref = expr->ref; ref; ref = ref->next)
7018 if (ref->next == NULL)
7019 break;
7021 if (ref->type == REF_COMPONENT)
7023 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
7024 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
7028 full_array_var = false;
7029 contiguous = false;
7031 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
7032 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
7034 sym = full_array_var ? expr->symtree->n.sym : NULL;
7036 /* The symbol should have an array specification. */
7037 gcc_assert (!sym || sym->as || ref->u.ar.as);
7039 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
7041 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
7042 expr->ts.u.cl->backend_decl = tmp;
7043 se->string_length = tmp;
7046 /* Is this the result of the enclosing procedure? */
7047 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
7048 if (this_array_result
7049 && (sym->backend_decl != current_function_decl)
7050 && (sym->backend_decl != parent))
7051 this_array_result = false;
7053 /* Passing address of the array if it is not pointer or assumed-shape. */
7054 if (full_array_var && g77 && !this_array_result
7055 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7057 tmp = gfc_get_symbol_decl (sym);
7059 if (sym->ts.type == BT_CHARACTER)
7060 se->string_length = sym->ts.u.cl->backend_decl;
7062 if (!sym->attr.pointer
7063 && sym->as
7064 && sym->as->type != AS_ASSUMED_SHAPE
7065 && sym->as->type != AS_DEFERRED
7066 && sym->as->type != AS_ASSUMED_RANK
7067 && !sym->attr.allocatable)
7069 /* Some variables are declared directly, others are declared as
7070 pointers and allocated on the heap. */
7071 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
7072 se->expr = tmp;
7073 else
7074 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7075 if (size)
7076 array_parameter_size (tmp, expr, size);
7077 return;
7080 if (sym->attr.allocatable)
7082 if (sym->attr.dummy || sym->attr.result)
7084 gfc_conv_expr_descriptor (se, expr);
7085 tmp = se->expr;
7087 if (size)
7088 array_parameter_size (tmp, expr, size);
7089 se->expr = gfc_conv_array_data (tmp);
7090 return;
7094 /* A convenient reduction in scope. */
7095 contiguous = g77 && !this_array_result && contiguous;
7097 /* There is no need to pack and unpack the array, if it is contiguous
7098 and not a deferred- or assumed-shape array, or if it is simply
7099 contiguous. */
7100 no_pack = ((sym && sym->as
7101 && !sym->attr.pointer
7102 && sym->as->type != AS_DEFERRED
7103 && sym->as->type != AS_ASSUMED_RANK
7104 && sym->as->type != AS_ASSUMED_SHAPE)
7106 (ref && ref->u.ar.as
7107 && ref->u.ar.as->type != AS_DEFERRED
7108 && ref->u.ar.as->type != AS_ASSUMED_RANK
7109 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
7111 gfc_is_simply_contiguous (expr, false));
7113 no_pack = contiguous && no_pack;
7115 /* Array constructors are always contiguous and do not need packing. */
7116 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
7118 /* Same is true of contiguous sections from allocatable variables. */
7119 good_allocatable = contiguous
7120 && expr->symtree
7121 && expr->symtree->n.sym->attr.allocatable;
7123 /* Or ultimate allocatable components. */
7124 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
7126 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
7128 gfc_conv_expr_descriptor (se, expr);
7129 if (expr->ts.type == BT_CHARACTER)
7130 se->string_length = expr->ts.u.cl->backend_decl;
7131 if (size)
7132 array_parameter_size (se->expr, expr, size);
7133 se->expr = gfc_conv_array_data (se->expr);
7134 return;
7137 if (this_array_result)
7139 /* Result of the enclosing function. */
7140 gfc_conv_expr_descriptor (se, expr);
7141 if (size)
7142 array_parameter_size (se->expr, expr, size);
7143 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7145 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
7146 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
7147 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
7148 se->expr));
7150 return;
7152 else
7154 /* Every other type of array. */
7155 se->want_pointer = 1;
7156 gfc_conv_expr_descriptor (se, expr);
7157 if (size)
7158 array_parameter_size (build_fold_indirect_ref_loc (input_location,
7159 se->expr),
7160 expr, size);
7163 /* Deallocate the allocatable components of structures that are
7164 not variable. */
7165 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
7166 && expr->ts.u.derived->attr.alloc_comp
7167 && expr->expr_type != EXPR_VARIABLE)
7169 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
7170 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
7172 /* The components shall be deallocated before their containing entity. */
7173 gfc_prepend_expr_to_block (&se->post, tmp);
7176 if (g77 || (fsym && fsym->attr.contiguous
7177 && !gfc_is_simply_contiguous (expr, false)))
7179 tree origptr = NULL_TREE;
7181 desc = se->expr;
7183 /* For contiguous arrays, save the original value of the descriptor. */
7184 if (!g77)
7186 origptr = gfc_create_var (pvoid_type_node, "origptr");
7187 tmp = build_fold_indirect_ref_loc (input_location, desc);
7188 tmp = gfc_conv_array_data (tmp);
7189 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7190 TREE_TYPE (origptr), origptr,
7191 fold_convert (TREE_TYPE (origptr), tmp));
7192 gfc_add_expr_to_block (&se->pre, tmp);
7195 /* Repack the array. */
7196 if (gfc_option.warn_array_temp)
7198 if (fsym)
7199 gfc_warning ("Creating array temporary at %L for argument '%s'",
7200 &expr->where, fsym->name);
7201 else
7202 gfc_warning ("Creating array temporary at %L", &expr->where);
7205 ptr = build_call_expr_loc (input_location,
7206 gfor_fndecl_in_pack, 1, desc);
7208 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7210 tmp = gfc_conv_expr_present (sym);
7211 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
7212 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
7213 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
7216 ptr = gfc_evaluate_now (ptr, &se->pre);
7218 /* Use the packed data for the actual argument, except for contiguous arrays,
7219 where the descriptor's data component is set. */
7220 if (g77)
7221 se->expr = ptr;
7222 else
7224 tmp = build_fold_indirect_ref_loc (input_location, desc);
7225 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
7228 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
7230 char * msg;
7232 if (fsym && proc_name)
7233 asprintf (&msg, "An array temporary was created for argument "
7234 "'%s' of procedure '%s'", fsym->name, proc_name);
7235 else
7236 asprintf (&msg, "An array temporary was created");
7238 tmp = build_fold_indirect_ref_loc (input_location,
7239 desc);
7240 tmp = gfc_conv_array_data (tmp);
7241 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7242 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7244 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7245 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7246 boolean_type_node,
7247 gfc_conv_expr_present (sym), tmp);
7249 gfc_trans_runtime_check (false, true, tmp, &se->pre,
7250 &expr->where, msg);
7251 free (msg);
7254 gfc_start_block (&block);
7256 /* Copy the data back. */
7257 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
7259 tmp = build_call_expr_loc (input_location,
7260 gfor_fndecl_in_unpack, 2, desc, ptr);
7261 gfc_add_expr_to_block (&block, tmp);
7264 /* Free the temporary. */
7265 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
7266 gfc_add_expr_to_block (&block, tmp);
7268 stmt = gfc_finish_block (&block);
7270 gfc_init_block (&block);
7271 /* Only if it was repacked. This code needs to be executed before the
7272 loop cleanup code. */
7273 tmp = build_fold_indirect_ref_loc (input_location,
7274 desc);
7275 tmp = gfc_conv_array_data (tmp);
7276 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7277 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7279 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7280 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7281 boolean_type_node,
7282 gfc_conv_expr_present (sym), tmp);
7284 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
7286 gfc_add_expr_to_block (&block, tmp);
7287 gfc_add_block_to_block (&block, &se->post);
7289 gfc_init_block (&se->post);
7291 /* Reset the descriptor pointer. */
7292 if (!g77)
7294 tmp = build_fold_indirect_ref_loc (input_location, desc);
7295 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
7298 gfc_add_block_to_block (&se->post, &block);
7303 /* Generate code to deallocate an array, if it is allocated. */
7305 tree
7306 gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
7308 tree tmp;
7309 tree var;
7310 stmtblock_t block;
7312 gfc_start_block (&block);
7314 var = gfc_conv_descriptor_data_get (descriptor);
7315 STRIP_NOPS (var);
7317 /* Call array_deallocate with an int * present in the second argument.
7318 Although it is ignored here, it's presence ensures that arrays that
7319 are already deallocated are ignored. */
7320 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
7321 NULL_TREE, NULL_TREE, NULL_TREE, true,
7322 expr, coarray);
7323 gfc_add_expr_to_block (&block, tmp);
7325 /* Zero the data pointer. */
7326 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7327 var, build_int_cst (TREE_TYPE (var), 0));
7328 gfc_add_expr_to_block (&block, tmp);
7330 return gfc_finish_block (&block);
7334 /* This helper function calculates the size in words of a full array. */
7336 static tree
7337 get_full_array_size (stmtblock_t *block, tree decl, int rank)
7339 tree idx;
7340 tree nelems;
7341 tree tmp;
7342 idx = gfc_rank_cst[rank - 1];
7343 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
7344 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
7345 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7346 nelems, tmp);
7347 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7348 tmp, gfc_index_one_node);
7349 tmp = gfc_evaluate_now (tmp, block);
7351 nelems = gfc_conv_descriptor_stride_get (decl, idx);
7352 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7353 nelems, tmp);
7354 return gfc_evaluate_now (tmp, block);
7358 /* Allocate dest to the same size as src, and copy src -> dest.
7359 If no_malloc is set, only the copy is done. */
7361 static tree
7362 duplicate_allocatable (tree dest, tree src, tree type, int rank,
7363 bool no_malloc)
7365 tree tmp;
7366 tree size;
7367 tree nelems;
7368 tree null_cond;
7369 tree null_data;
7370 stmtblock_t block;
7372 /* If the source is null, set the destination to null. Then,
7373 allocate memory to the destination. */
7374 gfc_init_block (&block);
7376 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7378 tmp = null_pointer_node;
7379 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
7380 gfc_add_expr_to_block (&block, tmp);
7381 null_data = gfc_finish_block (&block);
7383 gfc_init_block (&block);
7384 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7385 if (!no_malloc)
7387 tmp = gfc_call_malloc (&block, type, size);
7388 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7389 dest, fold_convert (type, tmp));
7390 gfc_add_expr_to_block (&block, tmp);
7393 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7394 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
7395 fold_convert (size_type_node, size));
7397 else
7399 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7400 null_data = gfc_finish_block (&block);
7402 gfc_init_block (&block);
7403 if (rank)
7404 nelems = get_full_array_size (&block, src, rank);
7405 else
7406 nelems = gfc_index_one_node;
7408 tmp = fold_convert (gfc_array_index_type,
7409 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7410 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7411 nelems, tmp);
7412 if (!no_malloc)
7414 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
7415 tmp = gfc_call_malloc (&block, tmp, size);
7416 gfc_conv_descriptor_data_set (&block, dest, tmp);
7419 /* We know the temporary and the value will be the same length,
7420 so can use memcpy. */
7421 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7422 tmp = build_call_expr_loc (input_location,
7423 tmp, 3, gfc_conv_descriptor_data_get (dest),
7424 gfc_conv_descriptor_data_get (src),
7425 fold_convert (size_type_node, size));
7428 gfc_add_expr_to_block (&block, tmp);
7429 tmp = gfc_finish_block (&block);
7431 /* Null the destination if the source is null; otherwise do
7432 the allocate and copy. */
7433 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
7434 null_cond = src;
7435 else
7436 null_cond = gfc_conv_descriptor_data_get (src);
7438 null_cond = convert (pvoid_type_node, null_cond);
7439 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7440 null_cond, null_pointer_node);
7441 return build3_v (COND_EXPR, null_cond, tmp, null_data);
7445 /* Allocate dest to the same size as src, and copy data src -> dest. */
7447 tree
7448 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
7450 return duplicate_allocatable (dest, src, type, rank, false);
7454 /* Copy data src -> dest. */
7456 tree
7457 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
7459 return duplicate_allocatable (dest, src, type, rank, true);
7463 /* Recursively traverse an object of derived type, generating code to
7464 deallocate, nullify or copy allocatable components. This is the work horse
7465 function for the functions named in this enum. */
7467 enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
7468 NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP,
7469 COPY_ALLOC_COMP_CAF};
7471 static tree
7472 structure_alloc_comps (gfc_symbol * der_type, tree decl,
7473 tree dest, int rank, int purpose)
7475 gfc_component *c;
7476 gfc_loopinfo loop;
7477 stmtblock_t fnblock;
7478 stmtblock_t loopbody;
7479 stmtblock_t tmpblock;
7480 tree decl_type;
7481 tree tmp;
7482 tree comp;
7483 tree dcmp;
7484 tree nelems;
7485 tree index;
7486 tree var;
7487 tree cdecl;
7488 tree ctype;
7489 tree vref, dref;
7490 tree null_cond = NULL_TREE;
7491 bool called_dealloc_with_status;
7493 gfc_init_block (&fnblock);
7495 decl_type = TREE_TYPE (decl);
7497 if ((POINTER_TYPE_P (decl_type) && rank != 0)
7498 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
7499 decl = build_fold_indirect_ref_loc (input_location, decl);
7501 /* Just in case in gets dereferenced. */
7502 decl_type = TREE_TYPE (decl);
7504 /* If this an array of derived types with allocatable components
7505 build a loop and recursively call this function. */
7506 if (TREE_CODE (decl_type) == ARRAY_TYPE
7507 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
7509 tmp = gfc_conv_array_data (decl);
7510 var = build_fold_indirect_ref_loc (input_location,
7511 tmp);
7513 /* Get the number of elements - 1 and set the counter. */
7514 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
7516 /* Use the descriptor for an allocatable array. Since this
7517 is a full array reference, we only need the descriptor
7518 information from dimension = rank. */
7519 tmp = get_full_array_size (&fnblock, decl, rank);
7520 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7521 gfc_array_index_type, tmp,
7522 gfc_index_one_node);
7524 null_cond = gfc_conv_descriptor_data_get (decl);
7525 null_cond = fold_build2_loc (input_location, NE_EXPR,
7526 boolean_type_node, null_cond,
7527 build_int_cst (TREE_TYPE (null_cond), 0));
7529 else
7531 /* Otherwise use the TYPE_DOMAIN information. */
7532 tmp = array_type_nelts (decl_type);
7533 tmp = fold_convert (gfc_array_index_type, tmp);
7536 /* Remember that this is, in fact, the no. of elements - 1. */
7537 nelems = gfc_evaluate_now (tmp, &fnblock);
7538 index = gfc_create_var (gfc_array_index_type, "S");
7540 /* Build the body of the loop. */
7541 gfc_init_block (&loopbody);
7543 vref = gfc_build_array_ref (var, index, NULL);
7545 if (purpose == COPY_ALLOC_COMP)
7547 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7549 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
7550 gfc_add_expr_to_block (&fnblock, tmp);
7552 tmp = build_fold_indirect_ref_loc (input_location,
7553 gfc_conv_array_data (dest));
7554 dref = gfc_build_array_ref (tmp, index, NULL);
7555 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
7557 else if (purpose == COPY_ONLY_ALLOC_COMP)
7559 tmp = build_fold_indirect_ref_loc (input_location,
7560 gfc_conv_array_data (dest));
7561 dref = gfc_build_array_ref (tmp, index, NULL);
7562 tmp = structure_alloc_comps (der_type, vref, dref, rank,
7563 COPY_ALLOC_COMP);
7565 else
7566 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
7568 gfc_add_expr_to_block (&loopbody, tmp);
7570 /* Build the loop and return. */
7571 gfc_init_loopinfo (&loop);
7572 loop.dimen = 1;
7573 loop.from[0] = gfc_index_zero_node;
7574 loop.loopvar[0] = index;
7575 loop.to[0] = nelems;
7576 gfc_trans_scalarizing_loops (&loop, &loopbody);
7577 gfc_add_block_to_block (&fnblock, &loop.pre);
7579 tmp = gfc_finish_block (&fnblock);
7580 if (null_cond != NULL_TREE)
7581 tmp = build3_v (COND_EXPR, null_cond, tmp,
7582 build_empty_stmt (input_location));
7584 return tmp;
7587 /* Otherwise, act on the components or recursively call self to
7588 act on a chain of components. */
7589 for (c = der_type->components; c; c = c->next)
7591 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
7592 || c->ts.type == BT_CLASS)
7593 && c->ts.u.derived->attr.alloc_comp;
7594 cdecl = c->backend_decl;
7595 ctype = TREE_TYPE (cdecl);
7597 switch (purpose)
7599 case DEALLOCATE_ALLOC_COMP:
7600 case DEALLOCATE_ALLOC_COMP_NO_CAF:
7602 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7603 (i.e. this function) so generate all the calls and suppress the
7604 recursion from here, if necessary. */
7605 called_dealloc_with_status = false;
7606 gfc_init_block (&tmpblock);
7608 if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
7609 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
7611 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7612 decl, cdecl, NULL_TREE);
7614 /* The finalizer frees allocatable components. */
7615 called_dealloc_with_status
7616 = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
7617 purpose == DEALLOCATE_ALLOC_COMP);
7619 else
7620 comp = NULL_TREE;
7622 if (c->attr.allocatable && !c->attr.proc_pointer
7623 && (c->attr.dimension
7624 || (c->attr.codimension
7625 && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
7627 if (comp == NULL_TREE)
7628 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7629 decl, cdecl, NULL_TREE);
7630 tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
7631 gfc_add_expr_to_block (&tmpblock, tmp);
7633 else if (c->attr.allocatable && !c->attr.codimension)
7635 /* Allocatable scalar components. */
7636 if (comp == NULL_TREE)
7637 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7638 decl, cdecl, NULL_TREE);
7640 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7641 c->ts);
7642 gfc_add_expr_to_block (&tmpblock, tmp);
7643 called_dealloc_with_status = true;
7645 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7646 void_type_node, comp,
7647 build_int_cst (TREE_TYPE (comp), 0));
7648 gfc_add_expr_to_block (&tmpblock, tmp);
7650 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
7651 && (!CLASS_DATA (c)->attr.codimension
7652 || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
7654 /* Allocatable CLASS components. */
7656 /* Add reference to '_data' component. */
7657 tmp = CLASS_DATA (c)->backend_decl;
7658 comp = fold_build3_loc (input_location, COMPONENT_REF,
7659 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7661 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
7662 tmp = gfc_trans_dealloc_allocated (comp,
7663 CLASS_DATA (c)->attr.codimension, NULL);
7664 else
7666 tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
7667 CLASS_DATA (c)->ts);
7668 gfc_add_expr_to_block (&tmpblock, tmp);
7669 called_dealloc_with_status = true;
7671 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7672 void_type_node, comp,
7673 build_int_cst (TREE_TYPE (comp), 0));
7675 gfc_add_expr_to_block (&tmpblock, tmp);
7678 if (cmp_has_alloc_comps
7679 && !c->attr.pointer
7680 && !called_dealloc_with_status)
7682 /* Do not deallocate the components of ultimate pointer
7683 components or iteratively call self if call has been made
7684 to gfc_trans_dealloc_allocated */
7685 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7686 decl, cdecl, NULL_TREE);
7687 rank = c->as ? c->as->rank : 0;
7688 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7689 rank, purpose);
7690 gfc_add_expr_to_block (&fnblock, tmp);
7693 /* Now add the deallocation of this component. */
7694 gfc_add_block_to_block (&fnblock, &tmpblock);
7695 break;
7697 case NULLIFY_ALLOC_COMP:
7698 if (c->attr.pointer)
7699 continue;
7700 else if (c->attr.allocatable
7701 && (c->attr.dimension|| c->attr.codimension))
7703 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7704 decl, cdecl, NULL_TREE);
7705 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7707 else if (c->attr.allocatable)
7709 /* Allocatable scalar components. */
7710 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7711 decl, cdecl, NULL_TREE);
7712 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7713 void_type_node, comp,
7714 build_int_cst (TREE_TYPE (comp), 0));
7715 gfc_add_expr_to_block (&fnblock, tmp);
7717 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7719 /* Allocatable CLASS components. */
7720 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7721 decl, cdecl, NULL_TREE);
7722 /* Add reference to '_data' component. */
7723 tmp = CLASS_DATA (c)->backend_decl;
7724 comp = fold_build3_loc (input_location, COMPONENT_REF,
7725 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7726 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
7727 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7728 else
7730 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7731 void_type_node, comp,
7732 build_int_cst (TREE_TYPE (comp), 0));
7733 gfc_add_expr_to_block (&fnblock, tmp);
7736 else if (cmp_has_alloc_comps)
7738 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7739 decl, cdecl, NULL_TREE);
7740 rank = c->as ? c->as->rank : 0;
7741 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7742 rank, purpose);
7743 gfc_add_expr_to_block (&fnblock, tmp);
7745 break;
7747 case COPY_ALLOC_COMP_CAF:
7748 if (!c->attr.codimension
7749 && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp)
7750 && (c->ts.type != BT_DERIVED
7751 || !c->ts.u.derived->attr.coarray_comp))
7752 continue;
7754 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7755 cdecl, NULL_TREE);
7756 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7757 cdecl, NULL_TREE);
7759 if (c->attr.codimension)
7761 if (c->ts.type == BT_CLASS)
7763 comp = gfc_class_data_get (comp);
7764 dcmp = gfc_class_data_get (dcmp);
7766 gfc_conv_descriptor_data_set (&fnblock, dcmp,
7767 gfc_conv_descriptor_data_get (comp));
7769 else
7771 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7772 rank, purpose);
7773 gfc_add_expr_to_block (&fnblock, tmp);
7776 break;
7778 case COPY_ALLOC_COMP:
7779 if (c->attr.pointer)
7780 continue;
7782 /* We need source and destination components. */
7783 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7784 cdecl, NULL_TREE);
7785 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7786 cdecl, NULL_TREE);
7787 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7789 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7791 tree ftn_tree;
7792 tree size;
7793 tree dst_data;
7794 tree src_data;
7795 tree null_data;
7797 dst_data = gfc_class_data_get (dcmp);
7798 src_data = gfc_class_data_get (comp);
7799 size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
7801 if (CLASS_DATA (c)->attr.dimension)
7803 nelems = gfc_conv_descriptor_size (src_data,
7804 CLASS_DATA (c)->as->rank);
7805 size = fold_build2_loc (input_location, MULT_EXPR,
7806 size_type_node, size,
7807 fold_convert (size_type_node,
7808 nelems));
7810 else
7811 nelems = build_int_cst (size_type_node, 1);
7813 if (CLASS_DATA (c)->attr.dimension
7814 || CLASS_DATA (c)->attr.codimension)
7816 src_data = gfc_conv_descriptor_data_get (src_data);
7817 dst_data = gfc_conv_descriptor_data_get (dst_data);
7820 gfc_init_block (&tmpblock);
7822 /* Coarray component have to have the same allocation status and
7823 shape/type-parameter/effective-type on the LHS and RHS of an
7824 intrinsic assignment. Hence, we did not deallocated them - and
7825 do not allocate them here. */
7826 if (!CLASS_DATA (c)->attr.codimension)
7828 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
7829 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
7830 gfc_add_modify (&tmpblock, dst_data,
7831 fold_convert (TREE_TYPE (dst_data), tmp));
7834 tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
7835 gfc_add_expr_to_block (&tmpblock, tmp);
7836 tmp = gfc_finish_block (&tmpblock);
7838 gfc_init_block (&tmpblock);
7839 gfc_add_modify (&tmpblock, dst_data,
7840 fold_convert (TREE_TYPE (dst_data),
7841 null_pointer_node));
7842 null_data = gfc_finish_block (&tmpblock);
7844 null_cond = fold_build2_loc (input_location, NE_EXPR,
7845 boolean_type_node, src_data,
7846 null_pointer_node);
7848 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
7849 tmp, null_data));
7850 continue;
7853 if (c->attr.allocatable && !c->attr.proc_pointer
7854 && !cmp_has_alloc_comps)
7856 rank = c->as ? c->as->rank : 0;
7857 if (c->attr.codimension)
7858 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
7859 else
7860 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7861 gfc_add_expr_to_block (&fnblock, tmp);
7864 if (cmp_has_alloc_comps)
7866 rank = c->as ? c->as->rank : 0;
7867 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7868 gfc_add_modify (&fnblock, dcmp, tmp);
7869 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7870 rank, purpose);
7871 gfc_add_expr_to_block (&fnblock, tmp);
7873 break;
7875 default:
7876 gcc_unreachable ();
7877 break;
7881 return gfc_finish_block (&fnblock);
7884 /* Recursively traverse an object of derived type, generating code to
7885 nullify allocatable components. */
7887 tree
7888 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7890 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7891 NULLIFY_ALLOC_COMP);
7895 /* Recursively traverse an object of derived type, generating code to
7896 deallocate allocatable components. */
7898 tree
7899 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7901 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7902 DEALLOCATE_ALLOC_COMP);
7906 /* Recursively traverse an object of derived type, generating code to
7907 deallocate allocatable components. But do not deallocate coarrays.
7908 To be used for intrinsic assignment, which may not change the allocation
7909 status of coarrays. */
7911 tree
7912 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
7914 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7915 DEALLOCATE_ALLOC_COMP_NO_CAF);
7919 tree
7920 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
7922 return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF);
7926 /* Recursively traverse an object of derived type, generating code to
7927 copy it and its allocatable components. */
7929 tree
7930 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7932 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
7936 /* Recursively traverse an object of derived type, generating code to
7937 copy only its allocatable components. */
7939 tree
7940 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
7942 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
7946 /* Returns the value of LBOUND for an expression. This could be broken out
7947 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
7948 called by gfc_alloc_allocatable_for_assignment. */
7949 static tree
7950 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
7952 tree lbound;
7953 tree ubound;
7954 tree stride;
7955 tree cond, cond1, cond3, cond4;
7956 tree tmp;
7957 gfc_ref *ref;
7959 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
7961 tmp = gfc_rank_cst[dim];
7962 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
7963 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
7964 stride = gfc_conv_descriptor_stride_get (desc, tmp);
7965 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7966 ubound, lbound);
7967 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
7968 stride, gfc_index_zero_node);
7969 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7970 boolean_type_node, cond3, cond1);
7971 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
7972 stride, gfc_index_zero_node);
7973 if (assumed_size)
7974 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7975 tmp, build_int_cst (gfc_array_index_type,
7976 expr->rank - 1));
7977 else
7978 cond = boolean_false_node;
7980 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7981 boolean_type_node, cond3, cond4);
7982 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
7983 boolean_type_node, cond, cond1);
7985 return fold_build3_loc (input_location, COND_EXPR,
7986 gfc_array_index_type, cond,
7987 lbound, gfc_index_one_node);
7990 if (expr->expr_type == EXPR_FUNCTION)
7992 /* A conversion function, so use the argument. */
7993 gcc_assert (expr->value.function.isym
7994 && expr->value.function.isym->conversion);
7995 expr = expr->value.function.actual->expr;
7998 if (expr->expr_type == EXPR_VARIABLE)
8000 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
8001 for (ref = expr->ref; ref; ref = ref->next)
8003 if (ref->type == REF_COMPONENT
8004 && ref->u.c.component->as
8005 && ref->next
8006 && ref->next->u.ar.type == AR_FULL)
8007 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
8009 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
8012 return gfc_index_one_node;
8016 /* Returns true if an expression represents an lhs that can be reallocated
8017 on assignment. */
8019 bool
8020 gfc_is_reallocatable_lhs (gfc_expr *expr)
8022 gfc_ref * ref;
8024 if (!expr->ref)
8025 return false;
8027 /* An allocatable variable. */
8028 if (expr->symtree->n.sym->attr.allocatable
8029 && expr->ref
8030 && expr->ref->type == REF_ARRAY
8031 && expr->ref->u.ar.type == AR_FULL)
8032 return true;
8034 /* All that can be left are allocatable components. */
8035 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
8036 && expr->symtree->n.sym->ts.type != BT_CLASS)
8037 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
8038 return false;
8040 /* Find a component ref followed by an array reference. */
8041 for (ref = expr->ref; ref; ref = ref->next)
8042 if (ref->next
8043 && ref->type == REF_COMPONENT
8044 && ref->next->type == REF_ARRAY
8045 && !ref->next->next)
8046 break;
8048 if (!ref)
8049 return false;
8051 /* Return true if valid reallocatable lhs. */
8052 if (ref->u.c.component->attr.allocatable
8053 && ref->next->u.ar.type == AR_FULL)
8054 return true;
8056 return false;
8060 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8061 reallocate it. */
8063 tree
8064 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
8065 gfc_expr *expr1,
8066 gfc_expr *expr2)
8068 stmtblock_t realloc_block;
8069 stmtblock_t alloc_block;
8070 stmtblock_t fblock;
8071 gfc_ss *rss;
8072 gfc_ss *lss;
8073 gfc_array_info *linfo;
8074 tree realloc_expr;
8075 tree alloc_expr;
8076 tree size1;
8077 tree size2;
8078 tree array1;
8079 tree cond_null;
8080 tree cond;
8081 tree tmp;
8082 tree tmp2;
8083 tree lbound;
8084 tree ubound;
8085 tree desc;
8086 tree old_desc;
8087 tree desc2;
8088 tree offset;
8089 tree jump_label1;
8090 tree jump_label2;
8091 tree neq_size;
8092 tree lbd;
8093 int n;
8094 int dim;
8095 gfc_array_spec * as;
8097 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8098 Find the lhs expression in the loop chain and set expr1 and
8099 expr2 accordingly. */
8100 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
8102 expr2 = expr1;
8103 /* Find the ss for the lhs. */
8104 lss = loop->ss;
8105 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
8106 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
8107 break;
8108 if (lss == gfc_ss_terminator)
8109 return NULL_TREE;
8110 expr1 = lss->info->expr;
8113 /* Bail out if this is not a valid allocate on assignment. */
8114 if (!gfc_is_reallocatable_lhs (expr1)
8115 || (expr2 && !expr2->rank))
8116 return NULL_TREE;
8118 /* Find the ss for the lhs. */
8119 lss = loop->ss;
8120 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
8121 if (lss->info->expr == expr1)
8122 break;
8124 if (lss == gfc_ss_terminator)
8125 return NULL_TREE;
8127 linfo = &lss->info->data.array;
8129 /* Find an ss for the rhs. For operator expressions, we see the
8130 ss's for the operands. Any one of these will do. */
8131 rss = loop->ss;
8132 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
8133 if (rss->info->expr != expr1 && rss != loop->temp_ss)
8134 break;
8136 if (expr2 && rss == gfc_ss_terminator)
8137 return NULL_TREE;
8139 gfc_start_block (&fblock);
8141 /* Since the lhs is allocatable, this must be a descriptor type.
8142 Get the data and array size. */
8143 desc = linfo->descriptor;
8144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8145 array1 = gfc_conv_descriptor_data_get (desc);
8147 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8148 deallocated if expr is an array of different shape or any of the
8149 corresponding length type parameter values of variable and expr
8150 differ." This assures F95 compatibility. */
8151 jump_label1 = gfc_build_label_decl (NULL_TREE);
8152 jump_label2 = gfc_build_label_decl (NULL_TREE);
8154 /* Allocate if data is NULL. */
8155 cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8156 array1, build_int_cst (TREE_TYPE (array1), 0));
8157 tmp = build3_v (COND_EXPR, cond_null,
8158 build1_v (GOTO_EXPR, jump_label1),
8159 build_empty_stmt (input_location));
8160 gfc_add_expr_to_block (&fblock, tmp);
8162 /* Get arrayspec if expr is a full array. */
8163 if (expr2 && expr2->expr_type == EXPR_FUNCTION
8164 && expr2->value.function.isym
8165 && expr2->value.function.isym->conversion)
8167 /* For conversion functions, take the arg. */
8168 gfc_expr *arg = expr2->value.function.actual->expr;
8169 as = gfc_get_full_arrayspec_from_expr (arg);
8171 else if (expr2)
8172 as = gfc_get_full_arrayspec_from_expr (expr2);
8173 else
8174 as = NULL;
8176 /* If the lhs shape is not the same as the rhs jump to setting the
8177 bounds and doing the reallocation....... */
8178 for (n = 0; n < expr1->rank; n++)
8180 /* Check the shape. */
8181 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8182 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
8183 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8184 gfc_array_index_type,
8185 loop->to[n], loop->from[n]);
8186 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8187 gfc_array_index_type,
8188 tmp, lbound);
8189 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8190 gfc_array_index_type,
8191 tmp, ubound);
8192 cond = fold_build2_loc (input_location, NE_EXPR,
8193 boolean_type_node,
8194 tmp, gfc_index_zero_node);
8195 tmp = build3_v (COND_EXPR, cond,
8196 build1_v (GOTO_EXPR, jump_label1),
8197 build_empty_stmt (input_location));
8198 gfc_add_expr_to_block (&fblock, tmp);
8201 /* ....else jump past the (re)alloc code. */
8202 tmp = build1_v (GOTO_EXPR, jump_label2);
8203 gfc_add_expr_to_block (&fblock, tmp);
8205 /* Add the label to start automatic (re)allocation. */
8206 tmp = build1_v (LABEL_EXPR, jump_label1);
8207 gfc_add_expr_to_block (&fblock, tmp);
8209 /* If the lhs has not been allocated, its bounds will not have been
8210 initialized and so its size is set to zero. */
8211 size1 = gfc_create_var (gfc_array_index_type, NULL);
8212 gfc_init_block (&alloc_block);
8213 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
8214 gfc_init_block (&realloc_block);
8215 gfc_add_modify (&realloc_block, size1,
8216 gfc_conv_descriptor_size (desc, expr1->rank));
8217 tmp = build3_v (COND_EXPR, cond_null,
8218 gfc_finish_block (&alloc_block),
8219 gfc_finish_block (&realloc_block));
8220 gfc_add_expr_to_block (&fblock, tmp);
8222 /* Get the rhs size and fix it. */
8223 if (expr2)
8224 desc2 = rss->info->data.array.descriptor;
8225 else
8226 desc2 = NULL_TREE;
8228 size2 = gfc_index_one_node;
8229 for (n = 0; n < expr2->rank; n++)
8231 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8232 gfc_array_index_type,
8233 loop->to[n], loop->from[n]);
8234 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8235 gfc_array_index_type,
8236 tmp, gfc_index_one_node);
8237 size2 = fold_build2_loc (input_location, MULT_EXPR,
8238 gfc_array_index_type,
8239 tmp, size2);
8241 size2 = gfc_evaluate_now (size2, &fblock);
8243 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8244 size1, size2);
8245 neq_size = gfc_evaluate_now (cond, &fblock);
8247 /* Deallocation of allocatable components will have to occur on
8248 reallocation. Fix the old descriptor now. */
8249 if ((expr1->ts.type == BT_DERIVED)
8250 && expr1->ts.u.derived->attr.alloc_comp)
8251 old_desc = gfc_evaluate_now (desc, &fblock);
8252 else
8253 old_desc = NULL_TREE;
8255 /* Now modify the lhs descriptor and the associated scalarizer
8256 variables. F2003 7.4.1.3: "If variable is or becomes an
8257 unallocated allocatable variable, then it is allocated with each
8258 deferred type parameter equal to the corresponding type parameters
8259 of expr , with the shape of expr , and with each lower bound equal
8260 to the corresponding element of LBOUND(expr)."
8261 Reuse size1 to keep a dimension-by-dimension track of the
8262 stride of the new array. */
8263 size1 = gfc_index_one_node;
8264 offset = gfc_index_zero_node;
8266 for (n = 0; n < expr2->rank; n++)
8268 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8269 gfc_array_index_type,
8270 loop->to[n], loop->from[n]);
8271 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8272 gfc_array_index_type,
8273 tmp, gfc_index_one_node);
8275 lbound = gfc_index_one_node;
8276 ubound = tmp;
8278 if (as)
8280 lbd = get_std_lbound (expr2, desc2, n,
8281 as->type == AS_ASSUMED_SIZE);
8282 ubound = fold_build2_loc (input_location,
8283 MINUS_EXPR,
8284 gfc_array_index_type,
8285 ubound, lbound);
8286 ubound = fold_build2_loc (input_location,
8287 PLUS_EXPR,
8288 gfc_array_index_type,
8289 ubound, lbd);
8290 lbound = lbd;
8293 gfc_conv_descriptor_lbound_set (&fblock, desc,
8294 gfc_rank_cst[n],
8295 lbound);
8296 gfc_conv_descriptor_ubound_set (&fblock, desc,
8297 gfc_rank_cst[n],
8298 ubound);
8299 gfc_conv_descriptor_stride_set (&fblock, desc,
8300 gfc_rank_cst[n],
8301 size1);
8302 lbound = gfc_conv_descriptor_lbound_get (desc,
8303 gfc_rank_cst[n]);
8304 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
8305 gfc_array_index_type,
8306 lbound, size1);
8307 offset = fold_build2_loc (input_location, MINUS_EXPR,
8308 gfc_array_index_type,
8309 offset, tmp2);
8310 size1 = fold_build2_loc (input_location, MULT_EXPR,
8311 gfc_array_index_type,
8312 tmp, size1);
8315 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8316 the array offset is saved and the info.offset is used for a
8317 running offset. Use the saved_offset instead. */
8318 tmp = gfc_conv_descriptor_offset (desc);
8319 gfc_add_modify (&fblock, tmp, offset);
8320 if (linfo->saved_offset
8321 && TREE_CODE (linfo->saved_offset) == VAR_DECL)
8322 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
8324 /* Now set the deltas for the lhs. */
8325 for (n = 0; n < expr1->rank; n++)
8327 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8328 dim = lss->dim[n];
8329 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8330 gfc_array_index_type, tmp,
8331 loop->from[dim]);
8332 if (linfo->delta[dim]
8333 && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
8334 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
8337 /* Get the new lhs size in bytes. */
8338 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
8340 tmp = expr2->ts.u.cl->backend_decl;
8341 gcc_assert (expr1->ts.u.cl->backend_decl);
8342 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
8343 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
8345 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
8347 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
8348 tmp = fold_build2_loc (input_location, MULT_EXPR,
8349 gfc_array_index_type, tmp,
8350 expr1->ts.u.cl->backend_decl);
8352 else
8353 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
8354 tmp = fold_convert (gfc_array_index_type, tmp);
8355 size2 = fold_build2_loc (input_location, MULT_EXPR,
8356 gfc_array_index_type,
8357 tmp, size2);
8358 size2 = fold_convert (size_type_node, size2);
8359 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
8360 size2, size_one_node);
8361 size2 = gfc_evaluate_now (size2, &fblock);
8363 /* Realloc expression. Note that the scalarizer uses desc.data
8364 in the array reference - (*desc.data)[<element>]. */
8365 gfc_init_block (&realloc_block);
8367 if ((expr1->ts.type == BT_DERIVED)
8368 && expr1->ts.u.derived->attr.alloc_comp)
8370 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
8371 expr1->rank);
8372 gfc_add_expr_to_block (&realloc_block, tmp);
8375 tmp = build_call_expr_loc (input_location,
8376 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
8377 fold_convert (pvoid_type_node, array1),
8378 size2);
8379 gfc_conv_descriptor_data_set (&realloc_block,
8380 desc, tmp);
8382 if ((expr1->ts.type == BT_DERIVED)
8383 && expr1->ts.u.derived->attr.alloc_comp)
8385 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
8386 expr1->rank);
8387 gfc_add_expr_to_block (&realloc_block, tmp);
8390 realloc_expr = gfc_finish_block (&realloc_block);
8392 /* Only reallocate if sizes are different. */
8393 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
8394 build_empty_stmt (input_location));
8395 realloc_expr = tmp;
8398 /* Malloc expression. */
8399 gfc_init_block (&alloc_block);
8400 tmp = build_call_expr_loc (input_location,
8401 builtin_decl_explicit (BUILT_IN_MALLOC),
8402 1, size2);
8403 gfc_conv_descriptor_data_set (&alloc_block,
8404 desc, tmp);
8405 tmp = gfc_conv_descriptor_dtype (desc);
8406 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
8407 if ((expr1->ts.type == BT_DERIVED)
8408 && expr1->ts.u.derived->attr.alloc_comp)
8410 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
8411 expr1->rank);
8412 gfc_add_expr_to_block (&alloc_block, tmp);
8414 alloc_expr = gfc_finish_block (&alloc_block);
8416 /* Malloc if not allocated; realloc otherwise. */
8417 tmp = build_int_cst (TREE_TYPE (array1), 0);
8418 cond = fold_build2_loc (input_location, EQ_EXPR,
8419 boolean_type_node,
8420 array1, tmp);
8421 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
8422 gfc_add_expr_to_block (&fblock, tmp);
8424 /* Make sure that the scalarizer data pointer is updated. */
8425 if (linfo->data
8426 && TREE_CODE (linfo->data) == VAR_DECL)
8428 tmp = gfc_conv_descriptor_data_get (desc);
8429 gfc_add_modify (&fblock, linfo->data, tmp);
8432 /* Add the exit label. */
8433 tmp = build1_v (LABEL_EXPR, jump_label2);
8434 gfc_add_expr_to_block (&fblock, tmp);
8436 return gfc_finish_block (&fblock);
8440 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8441 Do likewise, recursively if necessary, with the allocatable components of
8442 derived types. */
8444 void
8445 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
8447 tree type;
8448 tree tmp;
8449 tree descriptor;
8450 stmtblock_t init;
8451 stmtblock_t cleanup;
8452 locus loc;
8453 int rank;
8454 bool sym_has_alloc_comp, has_finalizer;
8456 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
8457 || sym->ts.type == BT_CLASS)
8458 && sym->ts.u.derived->attr.alloc_comp;
8459 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
8460 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
8462 /* Make sure the frontend gets these right. */
8463 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
8464 || has_finalizer);
8466 gfc_save_backend_locus (&loc);
8467 gfc_set_backend_locus (&sym->declared_at);
8468 gfc_init_block (&init);
8470 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
8471 || TREE_CODE (sym->backend_decl) == PARM_DECL);
8473 if (sym->ts.type == BT_CHARACTER
8474 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
8476 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
8477 gfc_trans_vla_type_sizes (sym, &init);
8480 /* Dummy, use associated and result variables don't need anything special. */
8481 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
8483 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8484 gfc_restore_backend_locus (&loc);
8485 return;
8488 descriptor = sym->backend_decl;
8490 /* Although static, derived types with default initializers and
8491 allocatable components must not be nulled wholesale; instead they
8492 are treated component by component. */
8493 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
8495 /* SAVEd variables are not freed on exit. */
8496 gfc_trans_static_array_pointer (sym);
8498 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8499 gfc_restore_backend_locus (&loc);
8500 return;
8503 /* Get the descriptor type. */
8504 type = TREE_TYPE (sym->backend_decl);
8506 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
8507 && !(sym->attr.pointer || sym->attr.allocatable))
8509 if (!sym->attr.save
8510 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
8512 if (sym->value == NULL
8513 || !gfc_has_default_initializer (sym->ts.u.derived))
8515 rank = sym->as ? sym->as->rank : 0;
8516 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
8517 descriptor, rank);
8518 gfc_add_expr_to_block (&init, tmp);
8520 else
8521 gfc_init_default_dt (sym, &init, false);
8524 else if (!GFC_DESCRIPTOR_TYPE_P (type))
8526 /* If the backend_decl is not a descriptor, we must have a pointer
8527 to one. */
8528 descriptor = build_fold_indirect_ref_loc (input_location,
8529 sym->backend_decl);
8530 type = TREE_TYPE (descriptor);
8533 /* NULLIFY the data pointer. */
8534 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
8535 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
8537 gfc_restore_backend_locus (&loc);
8538 gfc_init_block (&cleanup);
8540 /* Allocatable arrays need to be freed when they go out of scope.
8541 The allocatable components of pointers must not be touched. */
8542 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
8543 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
8544 && !sym->ns->proc_name->attr.is_main_program)
8546 gfc_expr *e;
8547 sym->attr.referenced = 1;
8548 e = gfc_lval_expr_from_sym (sym);
8549 gfc_add_finalizer_call (&cleanup, e);
8550 gfc_free_expr (e);
8552 else if ((!sym->attr.allocatable || !has_finalizer)
8553 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
8554 && !sym->attr.pointer && !sym->attr.save
8555 && !sym->ns->proc_name->attr.is_main_program)
8557 int rank;
8558 rank = sym->as ? sym->as->rank : 0;
8559 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
8560 gfc_add_expr_to_block (&cleanup, tmp);
8563 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
8564 && !sym->attr.save && !sym->attr.result
8565 && !sym->ns->proc_name->attr.is_main_program)
8567 gfc_expr *e;
8568 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
8569 tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
8570 sym->attr.codimension, e);
8571 if (e)
8572 gfc_free_expr (e);
8573 gfc_add_expr_to_block (&cleanup, tmp);
8576 gfc_add_init_cleanup (block, gfc_finish_block (&init),
8577 gfc_finish_block (&cleanup));
8580 /************ Expression Walking Functions ******************/
8582 /* Walk a variable reference.
8584 Possible extension - multiple component subscripts.
8585 x(:,:) = foo%a(:)%b(:)
8586 Transforms to
8587 forall (i=..., j=...)
8588 x(i,j) = foo%a(j)%b(i)
8589 end forall
8590 This adds a fair amount of complexity because you need to deal with more
8591 than one ref. Maybe handle in a similar manner to vector subscripts.
8592 Maybe not worth the effort. */
8595 static gfc_ss *
8596 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
8598 gfc_ref *ref;
8600 for (ref = expr->ref; ref; ref = ref->next)
8601 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
8602 break;
8604 return gfc_walk_array_ref (ss, expr, ref);
8608 gfc_ss *
8609 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
8611 gfc_array_ref *ar;
8612 gfc_ss *newss;
8613 int n;
8615 for (; ref; ref = ref->next)
8617 if (ref->type == REF_SUBSTRING)
8619 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
8620 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
8623 /* We're only interested in array sections from now on. */
8624 if (ref->type != REF_ARRAY)
8625 continue;
8627 ar = &ref->u.ar;
8629 switch (ar->type)
8631 case AR_ELEMENT:
8632 for (n = ar->dimen - 1; n >= 0; n--)
8633 ss = gfc_get_scalar_ss (ss, ar->start[n]);
8634 break;
8636 case AR_FULL:
8637 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
8638 newss->info->data.array.ref = ref;
8640 /* Make sure array is the same as array(:,:), this way
8641 we don't need to special case all the time. */
8642 ar->dimen = ar->as->rank;
8643 for (n = 0; n < ar->dimen; n++)
8645 ar->dimen_type[n] = DIMEN_RANGE;
8647 gcc_assert (ar->start[n] == NULL);
8648 gcc_assert (ar->end[n] == NULL);
8649 gcc_assert (ar->stride[n] == NULL);
8651 ss = newss;
8652 break;
8654 case AR_SECTION:
8655 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
8656 newss->info->data.array.ref = ref;
8658 /* We add SS chains for all the subscripts in the section. */
8659 for (n = 0; n < ar->dimen; n++)
8661 gfc_ss *indexss;
8663 switch (ar->dimen_type[n])
8665 case DIMEN_ELEMENT:
8666 /* Add SS for elemental (scalar) subscripts. */
8667 gcc_assert (ar->start[n]);
8668 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
8669 indexss->loop_chain = gfc_ss_terminator;
8670 newss->info->data.array.subscript[n] = indexss;
8671 break;
8673 case DIMEN_RANGE:
8674 /* We don't add anything for sections, just remember this
8675 dimension for later. */
8676 newss->dim[newss->dimen] = n;
8677 newss->dimen++;
8678 break;
8680 case DIMEN_VECTOR:
8681 /* Create a GFC_SS_VECTOR index in which we can store
8682 the vector's descriptor. */
8683 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
8684 1, GFC_SS_VECTOR);
8685 indexss->loop_chain = gfc_ss_terminator;
8686 newss->info->data.array.subscript[n] = indexss;
8687 newss->dim[newss->dimen] = n;
8688 newss->dimen++;
8689 break;
8691 default:
8692 /* We should know what sort of section it is by now. */
8693 gcc_unreachable ();
8696 /* We should have at least one non-elemental dimension,
8697 unless we are creating a descriptor for a (scalar) coarray. */
8698 gcc_assert (newss->dimen > 0
8699 || newss->info->data.array.ref->u.ar.as->corank > 0);
8700 ss = newss;
8701 break;
8703 default:
8704 /* We should know what sort of section it is by now. */
8705 gcc_unreachable ();
8709 return ss;
8713 /* Walk an expression operator. If only one operand of a binary expression is
8714 scalar, we must also add the scalar term to the SS chain. */
8716 static gfc_ss *
8717 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
8719 gfc_ss *head;
8720 gfc_ss *head2;
8722 head = gfc_walk_subexpr (ss, expr->value.op.op1);
8723 if (expr->value.op.op2 == NULL)
8724 head2 = head;
8725 else
8726 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
8728 /* All operands are scalar. Pass back and let the caller deal with it. */
8729 if (head2 == ss)
8730 return head2;
8732 /* All operands require scalarization. */
8733 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
8734 return head2;
8736 /* One of the operands needs scalarization, the other is scalar.
8737 Create a gfc_ss for the scalar expression. */
8738 if (head == ss)
8740 /* First operand is scalar. We build the chain in reverse order, so
8741 add the scalar SS after the second operand. */
8742 head = head2;
8743 while (head && head->next != ss)
8744 head = head->next;
8745 /* Check we haven't somehow broken the chain. */
8746 gcc_assert (head);
8747 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
8749 else /* head2 == head */
8751 gcc_assert (head2 == head);
8752 /* Second operand is scalar. */
8753 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
8756 return head2;
8760 /* Reverse a SS chain. */
8762 gfc_ss *
8763 gfc_reverse_ss (gfc_ss * ss)
8765 gfc_ss *next;
8766 gfc_ss *head;
8768 gcc_assert (ss != NULL);
8770 head = gfc_ss_terminator;
8771 while (ss != gfc_ss_terminator)
8773 next = ss->next;
8774 /* Check we didn't somehow break the chain. */
8775 gcc_assert (next != NULL);
8776 ss->next = head;
8777 head = ss;
8778 ss = next;
8781 return (head);
8785 /* Given an expression referring to a procedure, return the symbol of its
8786 interface. We can't get the procedure symbol directly as we have to handle
8787 the case of (deferred) type-bound procedures. */
8789 gfc_symbol *
8790 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8792 gfc_symbol *sym;
8793 gfc_ref *ref;
8795 if (procedure_ref == NULL)
8796 return NULL;
8798 /* Normal procedure case. */
8799 sym = procedure_ref->symtree->n.sym;
8801 /* Typebound procedure case. */
8802 for (ref = procedure_ref->ref; ref; ref = ref->next)
8804 if (ref->type == REF_COMPONENT
8805 && ref->u.c.component->attr.proc_pointer)
8806 sym = ref->u.c.component->ts.interface;
8807 else
8808 sym = NULL;
8811 return sym;
8815 /* Walk the arguments of an elemental function.
8816 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8817 it is NULL, we don't do the check and the argument is assumed to be present.
8820 gfc_ss *
8821 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8822 gfc_symbol *proc_ifc, gfc_ss_type type)
8824 gfc_formal_arglist *dummy_arg;
8825 int scalar;
8826 gfc_ss *head;
8827 gfc_ss *tail;
8828 gfc_ss *newss;
8830 head = gfc_ss_terminator;
8831 tail = NULL;
8833 if (proc_ifc)
8834 dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
8835 else
8836 dummy_arg = NULL;
8838 scalar = 1;
8839 for (; arg; arg = arg->next)
8841 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
8842 continue;
8844 newss = gfc_walk_subexpr (head, arg->expr);
8845 if (newss == head)
8847 /* Scalar argument. */
8848 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
8849 newss = gfc_get_scalar_ss (head, arg->expr);
8850 newss->info->type = type;
8853 else
8854 scalar = 0;
8856 if (dummy_arg != NULL
8857 && dummy_arg->sym->attr.optional
8858 && arg->expr->expr_type == EXPR_VARIABLE
8859 && (gfc_expr_attr (arg->expr).optional
8860 || gfc_expr_attr (arg->expr).allocatable
8861 || gfc_expr_attr (arg->expr).pointer))
8862 newss->info->can_be_null_ref = true;
8864 head = newss;
8865 if (!tail)
8867 tail = head;
8868 while (tail->next != gfc_ss_terminator)
8869 tail = tail->next;
8872 if (dummy_arg != NULL)
8873 dummy_arg = dummy_arg->next;
8876 if (scalar)
8878 /* If all the arguments are scalar we don't need the argument SS. */
8879 gfc_free_ss_chain (head);
8880 /* Pass it back. */
8881 return ss;
8884 /* Add it onto the existing chain. */
8885 tail->next = ss;
8886 return head;
8890 /* Walk a function call. Scalar functions are passed back, and taken out of
8891 scalarization loops. For elemental functions we walk their arguments.
8892 The result of functions returning arrays is stored in a temporary outside
8893 the loop, so that the function is only called once. Hence we do not need
8894 to walk their arguments. */
8896 static gfc_ss *
8897 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
8899 gfc_intrinsic_sym *isym;
8900 gfc_symbol *sym;
8901 gfc_component *comp = NULL;
8903 isym = expr->value.function.isym;
8905 /* Handle intrinsic functions separately. */
8906 if (isym)
8907 return gfc_walk_intrinsic_function (ss, expr, isym);
8909 sym = expr->value.function.esym;
8910 if (!sym)
8911 sym = expr->symtree->n.sym;
8913 /* A function that returns arrays. */
8914 comp = gfc_get_proc_ptr_comp (expr);
8915 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
8916 || (comp && comp->attr.dimension))
8917 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
8919 /* Walk the parameters of an elemental function. For now we always pass
8920 by reference. */
8921 if (sym->attr.elemental || (comp && comp->attr.elemental))
8922 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
8923 gfc_get_proc_ifc_for_expr (expr),
8924 GFC_SS_REFERENCE);
8926 /* Scalar functions are OK as these are evaluated outside the scalarization
8927 loop. Pass back and let the caller deal with it. */
8928 return ss;
8932 /* An array temporary is constructed for array constructors. */
8934 static gfc_ss *
8935 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
8937 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
8941 /* Walk an expression. Add walked expressions to the head of the SS chain.
8942 A wholly scalar expression will not be added. */
8944 gfc_ss *
8945 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
8947 gfc_ss *head;
8949 switch (expr->expr_type)
8951 case EXPR_VARIABLE:
8952 head = gfc_walk_variable_expr (ss, expr);
8953 return head;
8955 case EXPR_OP:
8956 head = gfc_walk_op_expr (ss, expr);
8957 return head;
8959 case EXPR_FUNCTION:
8960 head = gfc_walk_function_expr (ss, expr);
8961 return head;
8963 case EXPR_CONSTANT:
8964 case EXPR_NULL:
8965 case EXPR_STRUCTURE:
8966 /* Pass back and let the caller deal with it. */
8967 break;
8969 case EXPR_ARRAY:
8970 head = gfc_walk_array_constructor (ss, expr);
8971 return head;
8973 case EXPR_SUBSTRING:
8974 /* Pass back and let the caller deal with it. */
8975 break;
8977 default:
8978 internal_error ("bad expression type during walk (%d)",
8979 expr->expr_type);
8981 return ss;
8985 /* Entry point for expression walking.
8986 A return value equal to the passed chain means this is
8987 a scalar expression. It is up to the caller to take whatever action is
8988 necessary to translate these. */
8990 gfc_ss *
8991 gfc_walk_expr (gfc_expr * expr)
8993 gfc_ss *res;
8995 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
8996 return gfc_reverse_ss (res);