]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-array.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
convert.c (convert): Replace fold (buildN (...)) with fold_buildN.
[thirdparty/gcc.git] / gcc / fortran / trans-array.c
CommitLineData
6de9cd9a 1/* Array translation routines
ec378180 2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
9fc4d79b 6This file is part of GCC.
6de9cd9a 7
9fc4d79b
TS		 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 2, or (at your option) any later
11version.
6de9cd9a 12
9fc4d79b
TS		 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
6de9cd9a
DN		 17
18You should have received a copy of the GNU General Public License
9fc4d79b
TS		 19along with GCC; see the file COPYING. If not, write to the Free
20Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2102111-1307, USA. */
6de9cd9a
DN		 22
23/* trans-array.c-- Various array related code, including scalarization,
24 allocation, initialization and other support routines. */
25
26/* How the scalarizer works.
27 In gfortran, array expressions use the same core routines as scalar
28 expressions.
29 First, a Scalarization State (SS) chain is built. This is done by walking
30 the expression tree, and building a linear list of the terms in the
31 expression. As the tree is walked, scalar subexpressions are translated.
32
33 The scalarization parameters are stored in a gfc_loopinfo structure.
34 First the start and stride of each term is calculated by
35 gfc_conv_ss_startstride. During this process the expressions for the array
36 descriptors and data pointers are also translated.
37
38 If the expression is an assignment, we must then resolve any dependencies.
39 In fortran all the rhs values of an assignment must be evaluated before
40 any assignments take place. This can require a temporary array to store the
41 values. We also require a temporary when we are passing array expressions
42 or vector subecripts as procedure parameters.
43
44 Array sections are passed without copying to a temporary. These use the
45 scalarizer to determine the shape of the section. The flag
46 loop->array_parameter tells the scalarizer that the actual values and loop
47 variables will not be required.
48
49 The function gfc_conv_loop_setup generates the scalarization setup code.
50 It determines the range of the scalarizing loop variables. If a temporary
51 is required, this is created and initialized. Code for scalar expressions
52 taken outside the loop is also generated at this time. Next the offset and
53 scaling required to translate from loop variables to array indices for each
54 term is calculated.
55
56 A call to gfc_start_scalarized_body marks the start of the scalarized
57 expression. This creates a scope and declares the loop variables. Before
58 calling this gfc_make_ss_chain_used must be used to indicate which terms
59 will be used inside this loop.
60
61 The scalar gfc_conv_* functions are then used to build the main body of the
62 scalarization loop. Scalarization loop variables and precalculated scalar
1f2959f0 63 values are automatically substituted. Note that gfc_advance_se_ss_chain
6de9cd9a
DN		 64 must be used, rather than changing the se->ss directly.
65
66 For assignment expressions requiring a temporary two sub loops are
67 generated. The first stores the result of the expression in the temporary,
68 the second copies it to the result. A call to
69 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70 the start of the copying loop. The temporary may be less than full rank.
71
72 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73 loops. The loops are added to the pre chain of the loopinfo. The post
74 chain may still contain cleanup code.
75
76 After the loop code has been added into its parent scope gfc_cleanup_loop
77 is called to free all the SS allocated by the scalarizer. */
78
79#include "config.h"
80#include "system.h"
81#include "coretypes.h"
82#include "tree.h"
eadf906f 83#include "tree-gimple.h"
6de9cd9a
DN		 84#include "ggc.h"
85#include "toplev.h"
86#include "real.h"
87#include "flags.h"
6de9cd9a
DN		 88#include "gfortran.h"
89#include "trans.h"
90#include "trans-stmt.h"
91#include "trans-types.h"
92#include "trans-array.h"
93#include "trans-const.h"
94#include "dependency.h"
95
96static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97
13413760 98/* The contents of this structure aren't actually used, just the address. */
6de9cd9a
DN		 99static gfc_ss gfc_ss_terminator_var;
100gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
101
6de9cd9a
DN		 102
103static tree
104gfc_array_dataptr_type (tree desc)
105{
106 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
107}
108
109
110/* Build expressions to access the members of an array descriptor.
111 It's surprisingly easy to mess up here, so never access
112 an array descriptor by "brute force", always use these
113 functions. This also avoids problems if we change the format
114 of an array descriptor.
115
116 To understand these magic numbers, look at the comments
117 before gfc_build_array_type() in trans-types.c.
118
119 The code within these defines should be the only code which knows the format
120 of an array descriptor.
121
122 Any code just needing to read obtain the bounds of an array should use
123 gfc_conv_array_* rather than the following functions as these will return
124 know constant values, and work with arrays which do not have descriptors.
125
126 Don't forget to #undef these! */
127
128#define DATA_FIELD 0
129#define OFFSET_FIELD 1
130#define DTYPE_FIELD 2
131#define DIMENSION_FIELD 3
132
133#define STRIDE_SUBFIELD 0
134#define LBOUND_SUBFIELD 1
135#define UBOUND_SUBFIELD 2
136
137tree
138gfc_conv_descriptor_data (tree desc)
139{
140 tree field;
141 tree type;
142
143 type = TREE_TYPE (desc);
6e45f57b 144 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
6de9cd9a
DN		 145
146 field = TYPE_FIELDS (type);
6e45f57b
PB		 147 gcc_assert (DATA_FIELD == 0);
148 gcc_assert (field != NULL_TREE
6de9cd9a
DN		 149 && TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
150 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE);
151
923ab88c 152 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
6de9cd9a
DN		 153}
154
155tree
156gfc_conv_descriptor_offset (tree desc)
157{
158 tree type;
159 tree field;
160
161 type = TREE_TYPE (desc);
6e45f57b 162 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
6de9cd9a
DN		 163
164 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
6e45f57b 165 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
6de9cd9a 166
923ab88c 167 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
6de9cd9a
DN		 168}
169
170tree
171gfc_conv_descriptor_dtype (tree desc)
172{
173 tree field;
174 tree type;
175
176 type = TREE_TYPE (desc);
6e45f57b 177 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
6de9cd9a
DN		 178
179 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
6e45f57b 180 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
6de9cd9a 181
923ab88c 182 return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
6de9cd9a
DN		 183}
184
185static tree
186gfc_conv_descriptor_dimension (tree desc, tree dim)
187{
188 tree field;
189 tree type;
190 tree tmp;
191
192 type = TREE_TYPE (desc);
6e45f57b 193 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
6de9cd9a
DN		 194
195 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
6e45f57b 196 gcc_assert (field != NULL_TREE
6de9cd9a
DN		 197 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
198 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
199
923ab88c 200 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
6de9cd9a
DN		 201 tmp = gfc_build_array_ref (tmp, dim);
202 return tmp;
203}
204
205tree
206gfc_conv_descriptor_stride (tree desc, tree dim)
207{
208 tree tmp;
209 tree field;
210
211 tmp = gfc_conv_descriptor_dimension (desc, dim);
212 field = TYPE_FIELDS (TREE_TYPE (tmp));
213 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
6e45f57b 214 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
6de9cd9a 215
923ab88c 216 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
6de9cd9a
DN		 217 return tmp;
218}
219
220tree
221gfc_conv_descriptor_lbound (tree desc, tree dim)
222{
223 tree tmp;
224 tree field;
225
226 tmp = gfc_conv_descriptor_dimension (desc, dim);
227 field = TYPE_FIELDS (TREE_TYPE (tmp));
228 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
6e45f57b 229 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
6de9cd9a 230
923ab88c 231 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
6de9cd9a
DN		 232 return tmp;
233}
234
235tree
236gfc_conv_descriptor_ubound (tree desc, tree dim)
237{
238 tree tmp;
239 tree field;
240
241 tmp = gfc_conv_descriptor_dimension (desc, dim);
242 field = TYPE_FIELDS (TREE_TYPE (tmp));
243 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
6e45f57b 244 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
6de9cd9a 245
923ab88c 246 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
6de9cd9a
DN		 247 return tmp;
248}
249
250
331c72f3 251/* Build an null array descriptor constructor. */
6de9cd9a 252
331c72f3
PB		 253tree
254gfc_build_null_descriptor (tree type)
6de9cd9a 255{
6de9cd9a 256 tree field;
331c72f3 257 tree tmp;
6de9cd9a 258
6e45f57b
PB		 259 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
260 gcc_assert (DATA_FIELD == 0);
6de9cd9a
DN		 261 field = TYPE_FIELDS (type);
262
331c72f3 263 /* Set a NULL data pointer. */
6de9cd9a
DN		 264 tmp = tree_cons (field, null_pointer_node, NULL_TREE);
265 tmp = build1 (CONSTRUCTOR, type, tmp);
266 TREE_CONSTANT (tmp) = 1;
267 TREE_INVARIANT (tmp) = 1;
331c72f3
PB		 268 /* All other fields are ignored. */
269
270 return tmp;
6de9cd9a
DN		 271}
272
273
274/* Cleanup those #defines. */
275
276#undef DATA_FIELD
277#undef OFFSET_FIELD
278#undef DTYPE_FIELD
279#undef DIMENSION_FIELD
280#undef STRIDE_SUBFIELD
281#undef LBOUND_SUBFIELD
282#undef UBOUND_SUBFIELD
283
284
285/* Mark a SS chain as used. Flags specifies in which loops the SS is used.
286 flags & 1 = Main loop body.
287 flags & 2 = temp copy loop. */
288
289void
290gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
291{
292 for (; ss != gfc_ss_terminator; ss = ss->next)
293 ss->useflags = flags;
294}
295
296static void gfc_free_ss (gfc_ss *);
297
298
299/* Free a gfc_ss chain. */
300
301static void
302gfc_free_ss_chain (gfc_ss * ss)
303{
304 gfc_ss *next;
305
306 while (ss != gfc_ss_terminator)
307 {
6e45f57b 308 gcc_assert (ss != NULL);
6de9cd9a
DN		 309 next = ss->next;
310 gfc_free_ss (ss);
311 ss = next;
312 }
313}
314
315
316/* Free a SS. */
317
318static void
319gfc_free_ss (gfc_ss * ss)
320{
321 int n;
322
323 switch (ss->type)
324 {
325 case GFC_SS_SECTION:
326 case GFC_SS_VECTOR:
327 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
328 {
329 if (ss->data.info.subscript[n])
330 gfc_free_ss_chain (ss->data.info.subscript[n]);
331 }
332 break;
333
334 default:
335 break;
336 }
337
338 gfc_free (ss);
339}
340
341
342/* Free all the SS associated with a loop. */
343
344void
345gfc_cleanup_loop (gfc_loopinfo * loop)
346{
347 gfc_ss *ss;
348 gfc_ss *next;
349
350 ss = loop->ss;
351 while (ss != gfc_ss_terminator)
352 {
6e45f57b 353 gcc_assert (ss != NULL);
6de9cd9a
DN		 354 next = ss->loop_chain;
355 gfc_free_ss (ss);
356 ss = next;
357 }
358}
359
360
361/* Associate a SS chain with a loop. */
362
363void
364gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
365{
366 gfc_ss *ss;
367
368 if (head == gfc_ss_terminator)
369 return;
370
371 ss = head;
372 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
373 {
374 if (ss->next == gfc_ss_terminator)
375 ss->loop_chain = loop->ss;
376 else
377 ss->loop_chain = ss->next;
378 }
6e45f57b 379 gcc_assert (ss == gfc_ss_terminator);
6de9cd9a
DN		 380 loop->ss = head;
381}
382
383
331c72f3
PB		 384/* Generate an initializer for a static pointer or allocatable array. */
385
386void
387gfc_trans_static_array_pointer (gfc_symbol * sym)
388{
389 tree type;
390
6e45f57b 391 gcc_assert (TREE_STATIC (sym->backend_decl));
331c72f3
PB		 392 /* Just zero the data member. */
393 type = TREE_TYPE (sym->backend_decl);
df7df328 394 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
331c72f3
PB		 395}
396
397
6de9cd9a 398/* Generate code to allocate an array temporary, or create a variable to
fc90a8f2
PB		 399 hold the data. If size is NULL zero the descriptor so that so that the
400 callee will allocate the array. Also generates code to free the array
401 afterwards. */
6de9cd9a
DN		 402
403static void
404gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
405 tree size, tree nelem)
406{
407 tree tmp;
408 tree args;
409 tree desc;
410 tree data;
411 bool onstack;
412
413 desc = info->descriptor;
414 data = gfc_conv_descriptor_data (desc);
fc90a8f2 415 if (size == NULL_TREE)
6de9cd9a 416 {
fc90a8f2
PB		 417 /* A callee allocated array. */
418 gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data),
419 gfc_index_zero_node));
6de9cd9a
DN		 420 info->data = data;
421 info->offset = gfc_index_zero_node;
fc90a8f2 422 onstack = FALSE;
6de9cd9a
DN		 423 }
424 else
425 {
fc90a8f2
PB		 426 /* Allocate the temporary. */
427 onstack = gfc_can_put_var_on_stack (size);
428
429 if (onstack)
430 {
431 /* Make a temporary variable to hold the data. */
10c7a96f
SB		 432 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
433 integer_one_node);
fc90a8f2
PB		 434 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
435 tmp);
436 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
437 tmp);
438 tmp = gfc_create_var (tmp, "A");
439 tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
440 gfc_add_modify_expr (&loop->pre, data, tmp);
441 info->data = data;
442 info->offset = gfc_index_zero_node;
6de9cd9a 443
fc90a8f2 444 }
6de9cd9a 445 else
fc90a8f2
PB		 446 {
447 /* Allocate memory to hold the data. */
448 args = gfc_chainon_list (NULL_TREE, size);
6de9cd9a 449
fc90a8f2
PB		 450 if (gfc_index_integer_kind == 4)
451 tmp = gfor_fndecl_internal_malloc;
452 else if (gfc_index_integer_kind == 8)
453 tmp = gfor_fndecl_internal_malloc64;
454 else
6e45f57b 455 gcc_unreachable ();
fc90a8f2
PB		 456 tmp = gfc_build_function_call (tmp, args);
457 tmp = convert (TREE_TYPE (data), tmp);
458 gfc_add_modify_expr (&loop->pre, data, tmp);
459
460 info->data = data;
461 info->offset = gfc_index_zero_node;
462 }
6de9cd9a
DN		 463 }
464
465 /* The offset is zero because we create temporaries with a zero
466 lower bound. */
467 tmp = gfc_conv_descriptor_offset (desc);
468 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
469
470 if (!onstack)
471 {
472 /* Free the temporary. */
473 tmp = convert (pvoid_type_node, info->data);
474 tmp = gfc_chainon_list (NULL_TREE, tmp);
475 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
476 gfc_add_expr_to_block (&loop->post, tmp);
477 }
478}
479
480
481/* Generate code to allocate and initialize the descriptor for a temporary
e7dc5b4f 482 array. This is used for both temporaries needed by the scalarizer, and
fc90a8f2
PB		 483 functions returning arrays. Adjusts the loop variables to be zero-based,
484 and calculates the loop bounds for callee allocated arrays.
485 Also fills in the descriptor, data and offset fields of info if known.
486 Returns the size of the array, or NULL for a callee allocated array. */
6de9cd9a
DN		 487
488tree
489gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
40f20186 490 tree eltype)
6de9cd9a
DN		 491{
492 tree type;
493 tree desc;
494 tree tmp;
495 tree size;
496 tree nelem;
497 int n;
498 int dim;
499
6e45f57b 500 gcc_assert (info->dimen > 0);
6de9cd9a
DN		 501 /* Set the lower bound to zero. */
502 for (dim = 0; dim < info->dimen; dim++)
503 {
504 n = loop->order[dim];
505 if (n < loop->temp_dim)
6e45f57b 506 gcc_assert (integer_zerop (loop->from[n]));
6de9cd9a
DN		 507 else
508 {
fc90a8f2
PB		 509 /* Callee allocated arrays may not have a known bound yet. */
510 if (loop->to[n])
10c7a96f
SB		 511 loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
512 loop->to[n], loop->from[n]);
7ab92584 513 loop->from[n] = gfc_index_zero_node;
6de9cd9a
DN		 514 }
515
7ab92584
SB		 516 info->delta[dim] = gfc_index_zero_node;
517 info->start[dim] = gfc_index_zero_node;
518 info->stride[dim] = gfc_index_one_node;
6de9cd9a
DN		 519 info->dim[dim] = dim;
520 }
521
13413760 522 /* Initialize the descriptor. */
6de9cd9a
DN		 523 type =
524 gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
525 desc = gfc_create_var (type, "atmp");
526 GFC_DECL_PACKED_ARRAY (desc) = 1;
527
528 info->descriptor = desc;
7ab92584 529 size = gfc_index_one_node;
6de9cd9a
DN		 530
531 /* Fill in the array dtype. */
532 tmp = gfc_conv_descriptor_dtype (desc);
40b026d8 533 gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
6de9cd9a 534
7ab92584
SB		 535 /*
536 Fill in the bounds and stride. This is a packed array, so:
537
6de9cd9a
DN		 538 size = 1;
539 for (n = 0; n < rank; n++)
7ab92584
SB		 540 {
541 stride[n] = size
542 delta = ubound[n] + 1 - lbound[n];
543 size = size * delta;
544 }
545 size = size * sizeof(element);
546 */
547
6de9cd9a
DN		 548 for (n = 0; n < info->dimen; n++)
549 {
fc90a8f2
PB		 550 if (loop->to[n] == NULL_TREE)
551 {
552 /* For a callee allocated array express the loop bounds in terms
553 of the descriptor fields. */
923ab88c
TS		 554 tmp = build2 (MINUS_EXPR, gfc_array_index_type,
555 gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
556 gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
fc90a8f2
PB		 557 loop->to[n] = tmp;
558 size = NULL_TREE;
559 continue;
560 }
561
6de9cd9a
DN		 562 /* Store the stride and bound components in the descriptor. */
563 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
564 gfc_add_modify_expr (&loop->pre, tmp, size);
565
566 tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
7ab92584 567 gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
6de9cd9a
DN		 568
569 tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
570 gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
571
10c7a96f
SB		 572 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
573 loop->to[n], gfc_index_one_node);
6de9cd9a 574
10c7a96f 575 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
6de9cd9a
DN		 576 size = gfc_evaluate_now (size, &loop->pre);
577 }
578
6de9cd9a
DN		 579 /* Get the size of the array. */
580 nelem = size;
fc90a8f2 581 if (size)
10c7a96f
SB		 582 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
583 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
6de9cd9a
DN		 584
585 gfc_trans_allocate_array_storage (loop, info, size, nelem);
586
587 if (info->dimen > loop->temp_dim)
588 loop->temp_dim = info->dimen;
589
590 return size;
591}
592
593
594/* Make sure offset is a variable. */
595
596static void
597gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
598 tree * offsetvar)
599{
600 /* We should have already created the offset variable. We cannot
13413760 601 create it here because we may be in an inner scope. */
6e45f57b 602 gcc_assert (*offsetvar != NULL_TREE);
6de9cd9a
DN		 603 gfc_add_modify_expr (pblock, *offsetvar, *poffset);
604 *poffset = *offsetvar;
605 TREE_USED (*offsetvar) = 1;
606}
607
608
40f20186
PB		 609/* Assign an element of an array constructor. */
610
611static void
612gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
613 tree offset, gfc_se * se, gfc_expr * expr)
614{
615 tree tmp;
616 tree args;
617
618 gfc_conv_expr (se, expr);
619
620 /* Store the value. */
621 tmp = gfc_build_indirect_ref (pointer);
622 tmp = gfc_build_array_ref (tmp, offset);
623 if (expr->ts.type == BT_CHARACTER)
624 {
625 gfc_conv_string_parameter (se);
626 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
627 {
628 /* The temporary is an array of pointers. */
629 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
630 gfc_add_modify_expr (&se->pre, tmp, se->expr);
631 }
632 else
633 {
634 /* The temporary is an array of string values. */
635 tmp = gfc_build_addr_expr (pchar_type_node, tmp);
636 /* We know the temporary and the value will be the same length,
637 so can use memcpy. */
638 args = gfc_chainon_list (NULL_TREE, tmp);
639 args = gfc_chainon_list (args, se->expr);
640 args = gfc_chainon_list (args, se->string_length);
641 tmp = built_in_decls[BUILT_IN_MEMCPY];
642 tmp = gfc_build_function_call (tmp, args);
643 gfc_add_expr_to_block (&se->pre, tmp);
644 }
645 }
646 else
647 {
648 /* TODO: Should the frontend already have done this conversion? */
649 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
650 gfc_add_modify_expr (&se->pre, tmp, se->expr);
651 }
652
653 gfc_add_block_to_block (pblock, &se->pre);
654 gfc_add_block_to_block (pblock, &se->post);
655}
656
657
6de9cd9a
DN		 658/* Add the contents of an array to the constructor. */
659
660static void
661gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
662 tree type ATTRIBUTE_UNUSED,
663 tree pointer, gfc_expr * expr,
664 tree * poffset, tree * offsetvar)
665{
666 gfc_se se;
667 gfc_ss *ss;
668 gfc_loopinfo loop;
669 stmtblock_t body;
670 tree tmp;
671
672 /* We need this to be a variable so we can increment it. */
673 gfc_put_offset_into_var (pblock, poffset, offsetvar);
674
675 gfc_init_se (&se, NULL);
676
677 /* Walk the array expression. */
678 ss = gfc_walk_expr (expr);
6e45f57b 679 gcc_assert (ss != gfc_ss_terminator);
6de9cd9a
DN		 680
681 /* Initialize the scalarizer. */
682 gfc_init_loopinfo (&loop);
683 gfc_add_ss_to_loop (&loop, ss);
684
685 /* Initialize the loop. */
686 gfc_conv_ss_startstride (&loop);
687 gfc_conv_loop_setup (&loop);
688
689 /* Make the loop body. */
690 gfc_mark_ss_chain_used (ss, 1);
691 gfc_start_scalarized_body (&loop, &body);
692 gfc_copy_loopinfo_to_se (&se, &loop);
693 se.ss = ss;
694
40f20186
PB		 695 if (expr->ts.type == BT_CHARACTER)
696 gfc_todo_error ("character arrays in constructors");
6de9cd9a 697
40f20186 698 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
6e45f57b 699 gcc_assert (se.ss == gfc_ss_terminator);
6de9cd9a
DN		 700
701 /* Increment the offset. */
923ab88c 702 tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
6de9cd9a
DN		 703 gfc_add_modify_expr (&body, *poffset, tmp);
704
705 /* Finish the loop. */
6de9cd9a
DN		 706 gfc_trans_scalarizing_loops (&loop, &body);
707 gfc_add_block_to_block (&loop.pre, &loop.post);
708 tmp = gfc_finish_block (&loop.pre);
709 gfc_add_expr_to_block (pblock, tmp);
710
711 gfc_cleanup_loop (&loop);
712}
713
714
715/* Assign the values to the elements of an array constructor. */
716
717static void
718gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
719 tree pointer, gfc_constructor * c,
720 tree * poffset, tree * offsetvar)
721{
722 tree tmp;
6de9cd9a
DN		 723 stmtblock_t body;
724 tree loopbody;
725 gfc_se se;
726
727 for (; c; c = c->next)
728 {
729 /* If this is an iterator or an array, the offset must be a variable. */
730 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
731 gfc_put_offset_into_var (pblock, poffset, offsetvar);
732
733 gfc_start_block (&body);
734
735 if (c->expr->expr_type == EXPR_ARRAY)
736 {
737 /* Array constructors can be nested. */
738 gfc_trans_array_constructor_value (&body, type, pointer,
739 c->expr->value.constructor,
740 poffset, offsetvar);
741 }
742 else if (c->expr->rank > 0)
743 {
744 gfc_trans_array_constructor_subarray (&body, type, pointer,
745 c->expr, poffset, offsetvar);
746 }
747 else
748 {
749 /* This code really upsets the gimplifier so don't bother for now. */
750 gfc_constructor *p;
751 HOST_WIDE_INT n;
752 HOST_WIDE_INT size;
753
754 p = c;
755 n = 0;
756 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
757 {
758 p = p->next;
759 n++;
760 }
761 if (n < 4)
762 {
763 /* Scalar values. */
764 gfc_init_se (&se, NULL);
40f20186
PB		 765 gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
766 c->expr);
6de9cd9a 767
10c7a96f
SB		 768 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
769 *poffset, gfc_index_one_node);
6de9cd9a
DN		 770 }
771 else
772 {
773 /* Collect multiple scalar constants into a constructor. */
774 tree list;
775 tree init;
776 tree bound;
777 tree tmptype;
778
779 p = c;
780 list = NULL_TREE;
781 /* Count the number of consecutive scalar constants. */
782 while (p && !(p->iterator
783 || p->expr->expr_type != EXPR_CONSTANT))
784 {
785 gfc_init_se (&se, NULL);
786 gfc_conv_constant (&se, p->expr);
40f20186
PB		 787 if (p->expr->ts.type == BT_CHARACTER
788 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
789 (TREE_TYPE (pointer)))))
790 {
791 /* For constant character array constructors we build
792 an array of pointers. */
793 se.expr = gfc_build_addr_expr (pchar_type_node,
794 se.expr);
795 }
796
6de9cd9a
DN		 797 list = tree_cons (NULL_TREE, se.expr, list);
798 c = p;
799 p = p->next;
800 }
801
7d60be94 802 bound = build_int_cst (NULL_TREE, n - 1);
6de9cd9a
DN		 803 /* Create an array type to hold them. */
804 tmptype = build_range_type (gfc_array_index_type,
7ab92584 805 gfc_index_zero_node, bound);
6de9cd9a
DN		 806 tmptype = build_array_type (type, tmptype);
807
808 init = build1 (CONSTRUCTOR, tmptype, nreverse (list));
809 TREE_CONSTANT (init) = 1;
810 TREE_INVARIANT (init) = 1;
811 TREE_STATIC (init) = 1;
812 /* Create a static variable to hold the data. */
813 tmp = gfc_create_var (tmptype, "data");
814 TREE_STATIC (tmp) = 1;
815 TREE_CONSTANT (tmp) = 1;
816 TREE_INVARIANT (tmp) = 1;
817 DECL_INITIAL (tmp) = init;
818 init = tmp;
819
820 /* Use BUILTIN_MEMCPY to assign the values. */
821 tmp = gfc_build_indirect_ref (pointer);
822 tmp = gfc_build_array_ref (tmp, *poffset);
823 tmp = gfc_build_addr_expr (NULL, tmp);
824 init = gfc_build_addr_expr (NULL, init);
825
826 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
7d60be94 827 bound = build_int_cst (NULL_TREE, n * size);
6de9cd9a
DN		 828 tmp = gfc_chainon_list (NULL_TREE, tmp);
829 tmp = gfc_chainon_list (tmp, init);
830 tmp = gfc_chainon_list (tmp, bound);
831 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
832 tmp);
833 gfc_add_expr_to_block (&body, tmp);
834
10c7a96f
SB		 835 *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
836 *poffset, bound);
6de9cd9a
DN		 837 }
838 if (!INTEGER_CST_P (*poffset))
839 {
840 gfc_add_modify_expr (&body, *offsetvar, *poffset);
841 *poffset = *offsetvar;
842 }
843 }
844
845 /* The frontend should already have done any expansions. */
846 if (c->iterator)
847 {
848 tree end;
849 tree step;
850 tree loopvar;
851 tree exit_label;
852
853 loopbody = gfc_finish_block (&body);
854
855 gfc_init_se (&se, NULL);
856 gfc_conv_expr (&se, c->iterator->var);
857 gfc_add_block_to_block (pblock, &se.pre);
858 loopvar = se.expr;
859
13413760 860 /* Initialize the loop. */
6de9cd9a
DN		 861 gfc_init_se (&se, NULL);
862 gfc_conv_expr_val (&se, c->iterator->start);
863 gfc_add_block_to_block (pblock, &se.pre);
864 gfc_add_modify_expr (pblock, loopvar, se.expr);
865
866 gfc_init_se (&se, NULL);
867 gfc_conv_expr_val (&se, c->iterator->end);
868 gfc_add_block_to_block (pblock, &se.pre);
869 end = gfc_evaluate_now (se.expr, pblock);
870
871 gfc_init_se (&se, NULL);
872 gfc_conv_expr_val (&se, c->iterator->step);
873 gfc_add_block_to_block (pblock, &se.pre);
874 step = gfc_evaluate_now (se.expr, pblock);
875
876 /* Generate the loop body. */
877 exit_label = gfc_build_label_decl (NULL_TREE);
878 gfc_start_block (&body);
879
880 /* Generate the exit condition. */
923ab88c 881 end = build2 (GT_EXPR, boolean_type_node, loopvar, end);
6de9cd9a
DN		 882 tmp = build1_v (GOTO_EXPR, exit_label);
883 TREE_USED (exit_label) = 1;
923ab88c 884 tmp = build3_v (COND_EXPR, end, tmp, build_empty_stmt ());
6de9cd9a
DN		 885 gfc_add_expr_to_block (&body, tmp);
886
887 /* The main loop body. */
888 gfc_add_expr_to_block (&body, loopbody);
889
890 /* Increment the loop variable. */
923ab88c 891 tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
6de9cd9a
DN		 892 gfc_add_modify_expr (&body, loopvar, tmp);
893
894 /* Finish the loop. */
895 tmp = gfc_finish_block (&body);
923ab88c 896 tmp = build1_v (LOOP_EXPR, tmp);
6de9cd9a
DN		 897 gfc_add_expr_to_block (pblock, tmp);
898
899 /* Add the exit label. */
900 tmp = build1_v (LABEL_EXPR, exit_label);
901 gfc_add_expr_to_block (pblock, tmp);
902 }
903 else
904 {
905 /* Pass the code as is. */
906 tmp = gfc_finish_block (&body);
907 gfc_add_expr_to_block (pblock, tmp);
908 }
909 }
910}
911
912
913/* Get the size of an expression. Returns -1 if the size isn't constant.
914 Implied do loops with non-constant bounds are tricky because we must only
915 evaluate the bounds once. */
916
917static void
918gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
919{
920 gfc_iterator *i;
921 mpz_t val;
922 mpz_t len;
923
924 mpz_set_ui (*size, 0);
925 mpz_init (len);
926 mpz_init (val);
927
928 for (; c; c = c->next)
929 {
930 if (c->expr->expr_type == EXPR_ARRAY)
931 {
932 /* A nested array constructor. */
933 gfc_get_array_cons_size (&len, c->expr->value.constructor);
934 if (mpz_sgn (len) < 0)
935 {
936 mpz_set (*size, len);
937 mpz_clear (len);
938 mpz_clear (val);
939 return;
940 }
941 }
942 else
943 {
944 if (c->expr->rank > 0)
945 {
946 mpz_set_si (*size, -1);
947 mpz_clear (len);
948 mpz_clear (val);
949 return;
950 }
951 mpz_set_ui (len, 1);
952 }
953
954 if (c->iterator)
955 {
956 i = c->iterator;
957
958 if (i->start->expr_type != EXPR_CONSTANT
959 || i->end->expr_type != EXPR_CONSTANT
960 || i->step->expr_type != EXPR_CONSTANT)
961 {
962 mpz_set_si (*size, -1);
963 mpz_clear (len);
964 mpz_clear (val);
965 return;
966 }
967
968 mpz_add (val, i->end->value.integer, i->start->value.integer);
969 mpz_tdiv_q (val, val, i->step->value.integer);
970 mpz_add_ui (val, val, 1);
971 mpz_mul (len, len, val);
972 }
973 mpz_add (*size, *size, len);
974 }
975 mpz_clear (len);
976 mpz_clear (val);
977}
978
979
40f20186
PB		 980/* Figure out the string length of a variable reference expression.
981 Used by get_array_ctor_strlen. */
982
983static void
984get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
985{
986 gfc_ref *ref;
987 gfc_typespec *ts;
988
989 /* Don't bother if we already know the length is a constant. */
990 if (*len && INTEGER_CST_P (*len))
991 return;
992
993 ts = &expr->symtree->n.sym->ts;
994 for (ref = expr->ref; ref; ref = ref->next)
995 {
996 switch (ref->type)
997 {
998 case REF_ARRAY:
df7df328 999 /* Array references don't change the string length. */
40f20186
PB		 1000 break;
1001
1002 case COMPONENT_REF:
f7b529fa 1003 /* Use the length of the component. */
40f20186
PB		 1004 ts = &ref->u.c.component->ts;
1005 break;
1006
1007 default:
1008 /* TODO: Substrings are tricky because we can't evaluate the
1009 expression more than once. For now we just give up, and hope
1010 we can figure it out elsewhere. */
1011 return;
1012 }
1013 }
1014
1015 *len = ts->cl->backend_decl;
1016}
1017
1018
1019/* Figure out the string length of a character array constructor.
1020 Returns TRUE if all elements are character constants. */
1021
1022static bool
1023get_array_ctor_strlen (gfc_constructor * c, tree * len)
1024{
1025 bool is_const;
1026
1027 is_const = TRUE;
1028 for (; c; c = c->next)
1029 {
1030 switch (c->expr->expr_type)
1031 {
1032 case EXPR_CONSTANT:
1033 if (!(*len && INTEGER_CST_P (*len)))
d7177ab2 1034 *len = build_int_cstu (gfc_charlen_type_node,
40f20186
PB		 1035 c->expr->value.character.length);
1036 break;
1037
1038 case EXPR_ARRAY:
1039 if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1040 is_const = FALSE;
1041 break;
1042
1043 case EXPR_VARIABLE:
1044 is_const = false;
1045 get_array_ctor_var_strlen (c->expr, len);
1046 break;
1047
1048 default:
1049 is_const = FALSE;
1050 /* TODO: For now we just ignore anything we don't know how to
1051 handle, and hope we can figure it out a different way. */
1052 break;
1053 }
1054 }
1055
1056 return is_const;
1057}
1058
1059
6de9cd9a
DN		 1060/* Array constructors are handled by constructing a temporary, then using that
1061 within the scalarization loop. This is not optimal, but seems by far the
1062 simplest method. */
1063
1064static void
1065gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1066{
1067 tree offset;
1068 tree offsetvar;
1069 tree desc;
1070 tree size;
1071 tree type;
40f20186 1072 bool const_string;
6de9cd9a 1073
6de9cd9a 1074 ss->data.info.dimen = loop->dimen;
40f20186
PB		 1075
1076 if (ss->expr->ts.type == BT_CHARACTER)
1077 {
1078 const_string = get_array_ctor_strlen (ss->expr->value.constructor,
1079 &ss->string_length);
1080 if (!ss->string_length)
1081 gfc_todo_error ("complex character array constructors");
1082
1083 type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1084 if (const_string)
1085 type = build_pointer_type (type);
1086 }
1087 else
1088 {
1089 const_string = TRUE;
1090 type = gfc_typenode_for_spec (&ss->expr->ts);
1091 }
1092
1093 size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
6de9cd9a
DN		 1094
1095 desc = ss->data.info.descriptor;
7ab92584 1096 offset = gfc_index_zero_node;
6de9cd9a
DN		 1097 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1098 TREE_USED (offsetvar) = 0;
1099 gfc_trans_array_constructor_value (&loop->pre, type,
1100 ss->data.info.data,
1101 ss->expr->value.constructor, &offset,
1102 &offsetvar);
1103
1104 if (TREE_USED (offsetvar))
1105 pushdecl (offsetvar);
1106 else
6e45f57b 1107 gcc_assert (INTEGER_CST_P (offset));
6de9cd9a 1108#if 0
dfc46c1f 1109 /* Disable bound checking for now because it's probably broken. */
6de9cd9a
DN		 1110 if (flag_bounds_check)
1111 {
6e45f57b 1112 gcc_unreachable ();
6de9cd9a
DN		 1113 }
1114#endif
1115}
1116
1117
1118/* Add the pre and post chains for all the scalar expressions in a SS chain
1119 to loop. This is called after the loop parameters have been calculated,
1120 but before the actual scalarizing loops. */
6de9cd9a
DN		 1121
1122static void
1123gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1124{
1125 gfc_se se;
1126 int n;
1127
e9cfef64
PB		 1128 /* TODO: This can generate bad code if there are ordering dependencies.
1129 eg. a callee allocated function and an unknown size constructor. */
6e45f57b 1130 gcc_assert (ss != NULL);
6de9cd9a
DN		 1131
1132 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1133 {
6e45f57b 1134 gcc_assert (ss);
6de9cd9a
DN		 1135
1136 switch (ss->type)
1137 {
1138 case GFC_SS_SCALAR:
1139 /* Scalar expression. Evaluate this now. This includes elemental
1140 dimension indices, but not array section bounds. */
1141 gfc_init_se (&se, NULL);
1142 gfc_conv_expr (&se, ss->expr);
1143 gfc_add_block_to_block (&loop->pre, &se.pre);
1144
1145 if (ss->expr->ts.type != BT_CHARACTER)
1146 {
1147 /* Move the evaluation of scalar expressions outside the
1148 scalarization loop. */
1149 if (subscript)
1150 se.expr = convert(gfc_array_index_type, se.expr);
1151 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1152 gfc_add_block_to_block (&loop->pre, &se.post);
1153 }
1154 else
1155 gfc_add_block_to_block (&loop->post, &se.post);
1156
1157 ss->data.scalar.expr = se.expr;
40f20186 1158 ss->string_length = se.string_length;
6de9cd9a
DN		 1159 break;
1160
1161 case GFC_SS_REFERENCE:
1162 /* Scalar reference. Evaluate this now. */
1163 gfc_init_se (&se, NULL);
1164 gfc_conv_expr_reference (&se, ss->expr);
1165 gfc_add_block_to_block (&loop->pre, &se.pre);
1166 gfc_add_block_to_block (&loop->post, &se.post);
1167
1168 ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
40f20186 1169 ss->string_length = se.string_length;
6de9cd9a
DN		 1170 break;
1171
1172 case GFC_SS_SECTION:
1173 case GFC_SS_VECTOR:
1174 /* Scalarized expression. Evaluate any scalar subscripts. */
1175 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1176 {
1177 /* Add the expressions for scalar subscripts. */
1178 if (ss->data.info.subscript[n])
1179 gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1180 }
1181 break;
1182
1183 case GFC_SS_INTRINSIC:
1184 gfc_add_intrinsic_ss_code (loop, ss);
1185 break;
1186
1187 case GFC_SS_FUNCTION:
1188 /* Array function return value. We call the function and save its
1189 result in a temporary for use inside the loop. */
1190 gfc_init_se (&se, NULL);
1191 se.loop = loop;
1192 se.ss = ss;
1193 gfc_conv_expr (&se, ss->expr);
1194 gfc_add_block_to_block (&loop->pre, &se.pre);
1195 gfc_add_block_to_block (&loop->post, &se.post);
1196 break;
1197
1198 case GFC_SS_CONSTRUCTOR:
1199 gfc_trans_array_constructor (loop, ss);
1200 break;
1201
fc90a8f2 1202 case GFC_SS_TEMP:
e9cfef64
PB		 1203 case GFC_SS_COMPONENT:
1204 /* Do nothing. These are handled elsewhere. */
fc90a8f2
PB		 1205 break;
1206
6de9cd9a 1207 default:
6e45f57b 1208 gcc_unreachable ();
6de9cd9a
DN		 1209 }
1210 }
1211}
1212
1213
1214/* Translate expressions for the descriptor and data pointer of a SS. */
1215/*GCC ARRAYS*/
1216
1217static void
1218gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1219{
1220 gfc_se se;
1221 tree tmp;
1222
1223 /* Get the descriptor for the array to be scalarized. */
6e45f57b 1224 gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
6de9cd9a
DN		 1225 gfc_init_se (&se, NULL);
1226 se.descriptor_only = 1;
1227 gfc_conv_expr_lhs (&se, ss->expr);
1228 gfc_add_block_to_block (block, &se.pre);
1229 ss->data.info.descriptor = se.expr;
40f20186 1230 ss->string_length = se.string_length;
6de9cd9a
DN		 1231
1232 if (base)
1233 {
1234 /* Also the data pointer. */
1235 tmp = gfc_conv_array_data (se.expr);
1236 /* If this is a variable or address of a variable we use it directly.
2054fc29 1237 Otherwise we must evaluate it now to avoid breaking dependency
6de9cd9a
DN		 1238 analysis by pulling the expressions for elemental array indices
1239 inside the loop. */
1240 if (!(DECL_P (tmp)
1241 || (TREE_CODE (tmp) == ADDR_EXPR
1242 && DECL_P (TREE_OPERAND (tmp, 0)))))
1243 tmp = gfc_evaluate_now (tmp, block);
1244 ss->data.info.data = tmp;
1245
1246 tmp = gfc_conv_array_offset (se.expr);
1247 ss->data.info.offset = gfc_evaluate_now (tmp, block);
1248 }
1249}
1250
1251
1f2959f0 1252/* Initialize a gfc_loopinfo structure. */
6de9cd9a
DN		 1253
1254void
1255gfc_init_loopinfo (gfc_loopinfo * loop)
1256{
1257 int n;
1258
1259 memset (loop, 0, sizeof (gfc_loopinfo));
1260 gfc_init_block (&loop->pre);
1261 gfc_init_block (&loop->post);
1262
13413760 1263 /* Initially scalarize in order. */
6de9cd9a
DN		 1264 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1265 loop->order[n] = n;
1266
1267 loop->ss = gfc_ss_terminator;
1268}
1269
1270
e7dc5b4f 1271/* Copies the loop variable info to a gfc_se structure. Does not copy the SS
6de9cd9a
DN		 1272 chain. */
1273
1274void
1275gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1276{
1277 se->loop = loop;
1278}
1279
1280
1281/* Return an expression for the data pointer of an array. */
1282
1283tree
1284gfc_conv_array_data (tree descriptor)
1285{
1286 tree type;
1287
1288 type = TREE_TYPE (descriptor);
1289 if (GFC_ARRAY_TYPE_P (type))
1290 {
1291 if (TREE_CODE (type) == POINTER_TYPE)
1292 return descriptor;
1293 else
1294 {
13413760 1295 /* Descriptorless arrays. */
6de9cd9a
DN		 1296 return gfc_build_addr_expr (NULL, descriptor);
1297 }
1298 }
1299 else
1300 return gfc_conv_descriptor_data (descriptor);
1301}
1302
1303
1304/* Return an expression for the base offset of an array. */
1305
1306tree
1307gfc_conv_array_offset (tree descriptor)
1308{
1309 tree type;
1310
1311 type = TREE_TYPE (descriptor);
1312 if (GFC_ARRAY_TYPE_P (type))
1313 return GFC_TYPE_ARRAY_OFFSET (type);
1314 else
1315 return gfc_conv_descriptor_offset (descriptor);
1316}
1317
1318
1319/* Get an expression for the array stride. */
1320
1321tree
1322gfc_conv_array_stride (tree descriptor, int dim)
1323{
1324 tree tmp;
1325 tree type;
1326
1327 type = TREE_TYPE (descriptor);
1328
1329 /* For descriptorless arrays use the array size. */
1330 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1331 if (tmp != NULL_TREE)
1332 return tmp;
1333
1334 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1335 return tmp;
1336}
1337
1338
1339/* Like gfc_conv_array_stride, but for the lower bound. */
1340
1341tree
1342gfc_conv_array_lbound (tree descriptor, int dim)
1343{
1344 tree tmp;
1345 tree type;
1346
1347 type = TREE_TYPE (descriptor);
1348
1349 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1350 if (tmp != NULL_TREE)
1351 return tmp;
1352
1353 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1354 return tmp;
1355}
1356
1357
1358/* Like gfc_conv_array_stride, but for the upper bound. */
1359
1360tree
1361gfc_conv_array_ubound (tree descriptor, int dim)
1362{
1363 tree tmp;
1364 tree type;
1365
1366 type = TREE_TYPE (descriptor);
1367
1368 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1369 if (tmp != NULL_TREE)
1370 return tmp;
1371
1372 /* This should only ever happen when passing an assumed shape array
1373 as an actual parameter. The value will never be used. */
1374 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
7ab92584 1375 return gfc_index_zero_node;
6de9cd9a
DN		 1376
1377 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1378 return tmp;
1379}
1380
1381
1382/* Translate an array reference. The descriptor should be in se->expr.
1383 Do not use this function, it wil be removed soon. */
1384/*GCC ARRAYS*/
1385
1386static void
1387gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
13413760 1388 tree offset, int dimen)
6de9cd9a
DN		 1389{
1390 tree array;
1391 tree tmp;
1392 tree index;
1393 int n;
1394
1395 array = gfc_build_indirect_ref (pointer);
1396
1397 index = offset;
1398 for (n = 0; n < dimen; n++)
1399 {
1400 /* index = index + stride[n]*indices[n] */
1401 tmp = gfc_conv_array_stride (se->expr, n);
10c7a96f 1402 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp);
6de9cd9a 1403
10c7a96f 1404 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
6de9cd9a
DN		 1405 }
1406
1407 /* Result = data[index]. */
1408 tmp = gfc_build_array_ref (array, index);
1409
1410 /* Check we've used the correct number of dimensions. */
6e45f57b 1411 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
6de9cd9a
DN		 1412
1413 se->expr = tmp;
1414}
1415
1416
1417/* Generate code to perform an array index bound check. */
1418
1419static tree
1420gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1421{
1422 tree cond;
1423 tree fault;
1424 tree tmp;
1425
1426 if (!flag_bounds_check)
1427 return index;
1428
1429 index = gfc_evaluate_now (index, &se->pre);
1430 /* Check lower bound. */
1431 tmp = gfc_conv_array_lbound (descriptor, n);
10c7a96f 1432 fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
6de9cd9a
DN		 1433 /* Check upper bound. */
1434 tmp = gfc_conv_array_ubound (descriptor, n);
10c7a96f
SB		 1435 cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1436 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
6de9cd9a
DN		 1437
1438 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1439
1440 return index;
1441}
1442
1443
1444/* A reference to an array vector subscript. Uses recursion to handle nested
1445 vector subscripts. */
1446
1447static tree
1448gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
1449{
1450 tree descsave;
1451 tree indices[GFC_MAX_DIMENSIONS];
1452 gfc_array_ref *ar;
1453 gfc_ss_info *info;
1454 int n;
1455
6e45f57b 1456 gcc_assert (ss && ss->type == GFC_SS_VECTOR);
6de9cd9a
DN		 1457
1458 /* Save the descriptor. */
1459 descsave = se->expr;
1460 info = &ss->data.info;
1461 se->expr = info->descriptor;
1462
1463 ar = &info->ref->u.ar;
1464 for (n = 0; n < ar->dimen; n++)
1465 {
1466 switch (ar->dimen_type[n])
1467 {
1468 case DIMEN_ELEMENT:
6e45f57b 1469 gcc_assert (info->subscript[n] != gfc_ss_terminator
6de9cd9a
DN		 1470 && info->subscript[n]->type == GFC_SS_SCALAR);
1471 indices[n] = info->subscript[n]->data.scalar.expr;
1472 break;
1473
1474 case DIMEN_RANGE:
1475 indices[n] = index;
1476 break;
1477
1478 case DIMEN_VECTOR:
1479 index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
1480
1481 indices[n] =
1482 gfc_trans_array_bound_check (se, info->descriptor, index, n);
1483 break;
1484
1485 default:
6e45f57b 1486 gcc_unreachable ();
6de9cd9a
DN		 1487 }
1488 }
1489 /* Get the index from the vector. */
1490 gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
1491 index = se->expr;
1492 /* Put the descriptor back. */
1493 se->expr = descsave;
1494
1495 return index;
1496}
1497
1498
1499/* Return the offset for an index. Performs bound checking for elemental
e7dc5b4f 1500 dimensions. Single element references are processed separately. */
6de9cd9a
DN		 1501
1502static tree
1503gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1504 gfc_array_ref * ar, tree stride)
1505{
1506 tree index;
1507
1508 /* Get the index into the array for this dimension. */
1509 if (ar)
1510 {
6e45f57b 1511 gcc_assert (ar->type != AR_ELEMENT);
6de9cd9a
DN		 1512 if (ar->dimen_type[dim] == DIMEN_ELEMENT)
1513 {
6e45f57b 1514 gcc_assert (i == -1);
6de9cd9a 1515 /* Elemental dimension. */
6e45f57b 1516 gcc_assert (info->subscript[dim]
6de9cd9a
DN		 1517 && info->subscript[dim]->type == GFC_SS_SCALAR);
1518 /* We've already translated this value outside the loop. */
1519 index = info->subscript[dim]->data.scalar.expr;
1520
1521 index =
1522 gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1523 }
1524 else
1525 {
1526 /* Scalarized dimension. */
6e45f57b 1527 gcc_assert (info && se->loop);
6de9cd9a 1528
df7df328 1529 /* Multiply the loop variable by the stride and delta. */
6de9cd9a 1530 index = se->loop->loopvar[i];
10c7a96f
SB		 1531 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1532 info->stride[i]);
1533 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1534 info->delta[i]);
6de9cd9a
DN		 1535
1536 if (ar->dimen_type[dim] == DIMEN_VECTOR)
1537 {
1538 /* Handle vector subscripts. */
1539 index = gfc_conv_vector_array_index (se, index,
1540 info->subscript[dim]);
1541 index =
1542 gfc_trans_array_bound_check (se, info->descriptor, index,
1543 dim);
1544 }
1545 else
6e45f57b 1546 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
6de9cd9a
DN		 1547 }
1548 }
1549 else
1550 {
e9cfef64 1551 /* Temporary array or derived type component. */
6e45f57b 1552 gcc_assert (se->loop);
6de9cd9a 1553 index = se->loop->loopvar[se->loop->order[i]];
e9cfef64 1554 if (!integer_zerop (info->delta[i]))
10c7a96f
SB		 1555 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1556 index, info->delta[i]);
6de9cd9a
DN		 1557 }
1558
1559 /* Multiply by the stride. */
10c7a96f 1560 index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
6de9cd9a
DN		 1561
1562 return index;
1563}
1564
1565
1566/* Build a scalarized reference to an array. */
1567
1568static void
1569gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1570{
1571 gfc_ss_info *info;
1572 tree index;
1573 tree tmp;
1574 int n;
1575
1576 info = &se->ss->data.info;
1577 if (ar)
1578 n = se->loop->order[0];
1579 else
1580 n = 0;
1581
1582 index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1583 info->stride0);
1584 /* Add the offset for this dimension to the stored offset for all other
1585 dimensions. */
10c7a96f 1586 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
6de9cd9a
DN		 1587
1588 tmp = gfc_build_indirect_ref (info->data);
1589 se->expr = gfc_build_array_ref (tmp, index);
1590}
1591
1592
1593/* Translate access of temporary array. */
1594
1595void
1596gfc_conv_tmp_array_ref (gfc_se * se)
1597{
40f20186 1598 se->string_length = se->ss->string_length;
6de9cd9a
DN		 1599 gfc_conv_scalarized_array_ref (se, NULL);
1600}
1601
1602
1603/* Build an array reference. se->expr already holds the array descriptor.
1604 This should be either a variable, indirect variable reference or component
1605 reference. For arrays which do not have a descriptor, se->expr will be
1606 the data pointer.
1607 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1608
1609void
1610gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1611{
1612 int n;
1613 tree index;
1614 tree tmp;
1615 tree stride;
1616 tree fault;
1617 gfc_se indexse;
1618
e7dc5b4f 1619 /* Handle scalarized references separately. */
6de9cd9a
DN		 1620 if (ar->type != AR_ELEMENT)
1621 {
1622 gfc_conv_scalarized_array_ref (se, ar);
1623 return;
1624 }
1625
7ab92584 1626 index = gfc_index_zero_node;
6de9cd9a 1627
7ab92584 1628 fault = gfc_index_zero_node;
6de9cd9a
DN		 1629
1630 /* Calculate the offsets from all the dimensions. */
1631 for (n = 0; n < ar->dimen; n++)
1632 {
1f2959f0 1633 /* Calculate the index for this dimension. */
6de9cd9a
DN		 1634 gfc_init_se (&indexse, NULL);
1635 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1636 gfc_add_block_to_block (&se->pre, &indexse.pre);
1637
1638 if (flag_bounds_check)
1639 {
1640 /* Check array bounds. */
1641 tree cond;
1642
1643 indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1644
1645 tmp = gfc_conv_array_lbound (se->expr, n);
10c7a96f
SB		 1646 cond = fold_build2 (LT_EXPR, boolean_type_node,
1647 indexse.expr, tmp);
6de9cd9a 1648 fault =
10c7a96f 1649 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
6de9cd9a
DN		 1650
1651 tmp = gfc_conv_array_ubound (se->expr, n);
10c7a96f
SB		 1652 cond = fold_build2 (GT_EXPR, boolean_type_node,
1653 indexse.expr, tmp);
6de9cd9a 1654 fault =
10c7a96f 1655 fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
6de9cd9a
DN		 1656 }
1657
1658 /* Multiply the index by the stride. */
1659 stride = gfc_conv_array_stride (se->expr, n);
10c7a96f
SB		 1660 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1661 stride);
6de9cd9a
DN		 1662
1663 /* And add it to the total. */
10c7a96f 1664 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
6de9cd9a
DN		 1665 }
1666
1667 if (flag_bounds_check)
1668 gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1669
1670 tmp = gfc_conv_array_offset (se->expr);
1671 if (!integer_zerop (tmp))
10c7a96f 1672 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
6de9cd9a
DN		 1673
1674 /* Access the calculated element. */
1675 tmp = gfc_conv_array_data (se->expr);
1676 tmp = gfc_build_indirect_ref (tmp);
1677 se->expr = gfc_build_array_ref (tmp, index);
1678}
1679
1680
1681/* Generate the code to be executed immediately before entering a
1682 scalarization loop. */
1683
1684static void
1685gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1686 stmtblock_t * pblock)
1687{
1688 tree index;
1689 tree stride;
1690 gfc_ss_info *info;
1691 gfc_ss *ss;
1692 gfc_se se;
1693 int i;
1694
1695 /* This code will be executed before entering the scalarization loop
1696 for this dimension. */
1697 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1698 {
1699 if ((ss->useflags & flag) == 0)
1700 continue;
1701
1702 if (ss->type != GFC_SS_SECTION
e9cfef64
PB		 1703 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1704 && ss->type != GFC_SS_COMPONENT)
6de9cd9a
DN		 1705 continue;
1706
1707 info = &ss->data.info;
1708
1709 if (dim >= info->dimen)
1710 continue;
1711
1712 if (dim == info->dimen - 1)
1713 {
1714 /* For the outermost loop calculate the offset due to any
1715 elemental dimensions. It will have been initialized with the
1716 base offset of the array. */
1717 if (info->ref)
1718 {
1719 for (i = 0; i < info->ref->u.ar.dimen; i++)
1720 {
1721 if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1722 continue;
1723
1724 gfc_init_se (&se, NULL);
1725 se.loop = loop;
1726 se.expr = info->descriptor;
1727 stride = gfc_conv_array_stride (info->descriptor, i);
1728 index = gfc_conv_array_index_offset (&se, info, i, -1,
1729 &info->ref->u.ar,
1730 stride);
1731 gfc_add_block_to_block (pblock, &se.pre);
1732
10c7a96f
SB		 1733 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1734 info->offset, index);
6de9cd9a
DN		 1735 info->offset = gfc_evaluate_now (info->offset, pblock);
1736 }
1737
1738 i = loop->order[0];
1739 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1740 }
1741 else
1742 stride = gfc_conv_array_stride (info->descriptor, 0);
1743
1744 /* Calculate the stride of the innermost loop. Hopefully this will
1745 allow the backend optimizers to do their stuff more effectively.
1746 */
1747 info->stride0 = gfc_evaluate_now (stride, pblock);
1748 }
1749 else
1750 {
1751 /* Add the offset for the previous loop dimension. */
1752 gfc_array_ref *ar;
1753
1754 if (info->ref)
1755 {
1756 ar = &info->ref->u.ar;
1757 i = loop->order[dim + 1];
1758 }
1759 else
1760 {
1761 ar = NULL;
1762 i = dim + 1;
1763 }
1764
1765 gfc_init_se (&se, NULL);
1766 se.loop = loop;
1767 se.expr = info->descriptor;
1768 stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1769 index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1770 ar, stride);
1771 gfc_add_block_to_block (pblock, &se.pre);
10c7a96f
SB		 1772 info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1773 info->offset, index);
6de9cd9a
DN		 1774 info->offset = gfc_evaluate_now (info->offset, pblock);
1775 }
1776
e7dc5b4f 1777 /* Remember this offset for the second loop. */
6de9cd9a
DN		 1778 if (dim == loop->temp_dim - 1)
1779 info->saved_offset = info->offset;
1780 }
1781}
1782
1783
1784/* Start a scalarized expression. Creates a scope and declares loop
1785 variables. */
1786
1787void
1788gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
1789{
1790 int dim;
1791 int n;
1792 int flags;
1793
6e45f57b 1794 gcc_assert (!loop->array_parameter);
6de9cd9a
DN		 1795
1796 for (dim = loop->dimen - 1; dim >= 0; dim--)
1797 {
1798 n = loop->order[dim];
1799
1800 gfc_start_block (&loop->code[n]);
1801
1802 /* Create the loop variable. */
1803 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
1804
1805 if (dim < loop->temp_dim)
1806 flags = 3;
1807 else
1808 flags = 1;
1809 /* Calculate values that will be constant within this loop. */
1810 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
1811 }
1812 gfc_start_block (pbody);
1813}
1814
1815
1816/* Generates the actual loop code for a scalarization loop. */
1817
1818static void
1819gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
1820 stmtblock_t * pbody)
1821{
1822 stmtblock_t block;
1823 tree cond;
1824 tree tmp;
1825 tree loopbody;
1826 tree exit_label;
1827
1828 loopbody = gfc_finish_block (pbody);
1829
1830 /* Initialize the loopvar. */
1831 gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
1832
1833 exit_label = gfc_build_label_decl (NULL_TREE);
1834
1835 /* Generate the loop body. */
1836 gfc_init_block (&block);
1837
1838 /* The exit condition. */
923ab88c 1839 cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
6de9cd9a
DN		 1840 tmp = build1_v (GOTO_EXPR, exit_label);
1841 TREE_USED (exit_label) = 1;
923ab88c 1842 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
6de9cd9a
DN		 1843 gfc_add_expr_to_block (&block, tmp);
1844
1845 /* The main body. */
1846 gfc_add_expr_to_block (&block, loopbody);
1847
1848 /* Increment the loopvar. */
923ab88c
TS		 1849 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1850 loop->loopvar[n], gfc_index_one_node);
6de9cd9a
DN		 1851 gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
1852
1853 /* Build the loop. */
1854 tmp = gfc_finish_block (&block);
923ab88c 1855 tmp = build1_v (LOOP_EXPR, tmp);
6de9cd9a
DN		 1856 gfc_add_expr_to_block (&loop->code[n], tmp);
1857
1858 /* Add the exit label. */
1859 tmp = build1_v (LABEL_EXPR, exit_label);
1860 gfc_add_expr_to_block (&loop->code[n], tmp);
1861}
1862
1863
1864/* Finishes and generates the loops for a scalarized expression. */
1865
1866void
1867gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
1868{
1869 int dim;
1870 int n;
1871 gfc_ss *ss;
1872 stmtblock_t *pblock;
1873 tree tmp;
1874
1875 pblock = body;
1876 /* Generate the loops. */
1877 for (dim = 0; dim < loop->dimen; dim++)
1878 {
1879 n = loop->order[dim];
1880 gfc_trans_scalarized_loop_end (loop, n, pblock);
1881 loop->loopvar[n] = NULL_TREE;
1882 pblock = &loop->code[n];
1883 }
1884
1885 tmp = gfc_finish_block (pblock);
1886 gfc_add_expr_to_block (&loop->pre, tmp);
1887
1888 /* Clear all the used flags. */
1889 for (ss = loop->ss; ss; ss = ss->loop_chain)
1890 ss->useflags = 0;
1891}
1892
1893
1894/* Finish the main body of a scalarized expression, and start the secondary
1895 copying body. */
1896
1897void
1898gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
1899{
1900 int dim;
1901 int n;
1902 stmtblock_t *pblock;
1903 gfc_ss *ss;
1904
1905 pblock = body;
1906 /* We finish as many loops as are used by the temporary. */
1907 for (dim = 0; dim < loop->temp_dim - 1; dim++)
1908 {
1909 n = loop->order[dim];
1910 gfc_trans_scalarized_loop_end (loop, n, pblock);
1911 loop->loopvar[n] = NULL_TREE;
1912 pblock = &loop->code[n];
1913 }
1914
1915 /* We don't want to finish the outermost loop entirely. */
1916 n = loop->order[loop->temp_dim - 1];
1917 gfc_trans_scalarized_loop_end (loop, n, pblock);
1918
1919 /* Restore the initial offsets. */
1920 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1921 {
1922 if ((ss->useflags & 2) == 0)
1923 continue;
1924
1925 if (ss->type != GFC_SS_SECTION
e9cfef64
PB		 1926 && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1927 && ss->type != GFC_SS_COMPONENT)
6de9cd9a
DN		 1928 continue;
1929
1930 ss->data.info.offset = ss->data.info.saved_offset;
1931 }
1932
1933 /* Restart all the inner loops we just finished. */
1934 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
1935 {
1936 n = loop->order[dim];
1937
1938 gfc_start_block (&loop->code[n]);
1939
1940 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
1941
1942 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
1943 }
1944
1945 /* Start a block for the secondary copying code. */
1946 gfc_start_block (body);
1947}
1948
1949
1950/* Calculate the upper bound of an array section. */
1951
1952static tree
1953gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
1954{
1955 int dim;
1956 gfc_ss *vecss;
1957 gfc_expr *end;
1958 tree desc;
1959 tree bound;
1960 gfc_se se;
1961
6e45f57b 1962 gcc_assert (ss->type == GFC_SS_SECTION);
6de9cd9a
DN		 1963
1964 /* For vector array subscripts we want the size of the vector. */
1965 dim = ss->data.info.dim[n];
1966 vecss = ss;
1967 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1968 {
1969 vecss = vecss->data.info.subscript[dim];
6e45f57b 1970 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
6de9cd9a
DN		 1971 dim = vecss->data.info.dim[0];
1972 }
1973
6e45f57b 1974 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
6de9cd9a
DN		 1975 end = vecss->data.info.ref->u.ar.end[dim];
1976 desc = vecss->data.info.descriptor;
1977
1978 if (end)
1979 {
1980 /* The upper bound was specified. */
1981 gfc_init_se (&se, NULL);
1982 gfc_conv_expr_type (&se, end, gfc_array_index_type);
1983 gfc_add_block_to_block (pblock, &se.pre);
1984 bound = se.expr;
1985 }
1986 else
1987 {
f7b529fa 1988 /* No upper bound was specified, so use the bound of the array. */
6de9cd9a
DN		 1989 bound = gfc_conv_array_ubound (desc, dim);
1990 }
1991
1992 return bound;
1993}
1994
1995
1996/* Calculate the lower bound of an array section. */
1997
1998static void
1999gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2000{
2001 gfc_expr *start;
2002 gfc_expr *stride;
2003 gfc_ss *vecss;
2004 tree desc;
2005 gfc_se se;
2006 gfc_ss_info *info;
2007 int dim;
2008
2009 info = &ss->data.info;
2010
2011 dim = info->dim[n];
2012
2013 /* For vector array subscripts we want the size of the vector. */
2014 vecss = ss;
2015 while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2016 {
2017 vecss = vecss->data.info.subscript[dim];
6e45f57b 2018 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
6de9cd9a
DN		 2019 /* Get the descriptors for the vector subscripts as well. */
2020 if (!vecss->data.info.descriptor)
2021 gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
2022 dim = vecss->data.info.dim[0];
2023 }
2024
6e45f57b 2025 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
6de9cd9a
DN		 2026 start = vecss->data.info.ref->u.ar.start[dim];
2027 stride = vecss->data.info.ref->u.ar.stride[dim];
2028 desc = vecss->data.info.descriptor;
2029
2030 /* Calculate the start of the range. For vector subscripts this will
2031 be the range of the vector. */
2032 if (start)
2033 {
2034 /* Specified section start. */
2035 gfc_init_se (&se, NULL);
2036 gfc_conv_expr_type (&se, start, gfc_array_index_type);
2037 gfc_add_block_to_block (&loop->pre, &se.pre);
2038 info->start[n] = se.expr;
2039 }
2040 else
2041 {
2042 /* No lower bound specified so use the bound of the array. */
2043 info->start[n] = gfc_conv_array_lbound (desc, dim);
2044 }
2045 info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2046
2047 /* Calculate the stride. */
2048 if (stride == NULL)
7ab92584 2049 info->stride[n] = gfc_index_one_node;
6de9cd9a
DN		 2050 else
2051 {
2052 gfc_init_se (&se, NULL);
2053 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2054 gfc_add_block_to_block (&loop->pre, &se.pre);
2055 info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2056 }
2057}
2058
2059
2060/* Calculates the range start and stride for a SS chain. Also gets the
2061 descriptor and data pointer. The range of vector subscripts is the size
2062 of the vector. Array bounds are also checked. */
2063
2064void
2065gfc_conv_ss_startstride (gfc_loopinfo * loop)
2066{
2067 int n;
2068 tree tmp;
2069 gfc_ss *ss;
2070 gfc_ss *vecss;
2071 tree desc;
2072
2073 loop->dimen = 0;
2074 /* Determine the rank of the loop. */
2075 for (ss = loop->ss;
2076 ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2077 {
2078 switch (ss->type)
2079 {
2080 case GFC_SS_SECTION:
2081 case GFC_SS_CONSTRUCTOR:
2082 case GFC_SS_FUNCTION:
e9cfef64 2083 case GFC_SS_COMPONENT:
6de9cd9a
DN		 2084 loop->dimen = ss->data.info.dimen;
2085 break;
2086
2087 default:
2088 break;
2089 }
2090 }
2091
2092 if (loop->dimen == 0)
2093 gfc_todo_error ("Unable to determine rank of expression");
2094
2095
13413760 2096 /* Loop over all the SS in the chain. */
6de9cd9a
DN		 2097 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2098 {
e9cfef64
PB		 2099 if (ss->expr && ss->expr->shape && !ss->shape)
2100 ss->shape = ss->expr->shape;
2101
6de9cd9a
DN		 2102 switch (ss->type)
2103 {
2104 case GFC_SS_SECTION:
2105 /* Get the descriptor for the array. */
2106 gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2107
2108 for (n = 0; n < ss->data.info.dimen; n++)
2109 gfc_conv_section_startstride (loop, ss, n);
2110 break;
2111
2112 case GFC_SS_CONSTRUCTOR:
2113 case GFC_SS_FUNCTION:
2114 for (n = 0; n < ss->data.info.dimen; n++)
2115 {
7ab92584
SB		 2116 ss->data.info.start[n] = gfc_index_zero_node;
2117 ss->data.info.stride[n] = gfc_index_one_node;
6de9cd9a
DN		 2118 }
2119 break;
2120
2121 default:
2122 break;
2123 }
2124 }
2125
2126 /* The rest is just runtime bound checking. */
2127 if (flag_bounds_check)
2128 {
2129 stmtblock_t block;
2130 tree fault;
2131 tree bound;
2132 tree end;
2133 tree size[GFC_MAX_DIMENSIONS];
2134 gfc_ss_info *info;
2135 int dim;
2136
2137 gfc_start_block (&block);
2138
2139 fault = integer_zero_node;
2140 for (n = 0; n < loop->dimen; n++)
2141 size[n] = NULL_TREE;
2142
2143 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2144 {
2145 if (ss->type != GFC_SS_SECTION)
2146 continue;
2147
2148 /* TODO: range checking for mapped dimensions. */
2149 info = &ss->data.info;
2150
2151 /* This only checks scalarized dimensions, elemental dimensions are
2152 checked later. */
2153 for (n = 0; n < loop->dimen; n++)
2154 {
2155 dim = info->dim[n];
2156 vecss = ss;
2157 while (vecss->data.info.ref->u.ar.dimen_type[dim]
2158 == DIMEN_VECTOR)
2159 {
2160 vecss = vecss->data.info.subscript[dim];
6e45f57b 2161 gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
6de9cd9a
DN		 2162 dim = vecss->data.info.dim[0];
2163 }
6e45f57b 2164 gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
6de9cd9a
DN		 2165 == DIMEN_RANGE);
2166 desc = vecss->data.info.descriptor;
2167
2168 /* Check lower bound. */
2169 bound = gfc_conv_array_lbound (desc, dim);
2170 tmp = info->start[n];
10c7a96f
SB		 2171 tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2172 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2173 tmp);
6de9cd9a
DN		 2174
2175 /* Check the upper bound. */
2176 bound = gfc_conv_array_ubound (desc, dim);
2177 end = gfc_conv_section_upper_bound (ss, n, &block);
10c7a96f
SB		 2178 tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2179 fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2180 tmp);
6de9cd9a
DN		 2181
2182 /* Check the section sizes match. */
10c7a96f
SB		 2183 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2184 info->start[n]);
2185 tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2186 info->stride[n]);
6de9cd9a
DN		 2187 /* We remember the size of the first section, and check all the
2188 others against this. */
2189 if (size[n])
2190 {
2191 tmp =
10c7a96f 2192 fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
6de9cd9a 2193 fault =
923ab88c 2194 build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
6de9cd9a
DN		 2195 }
2196 else
2197 size[n] = gfc_evaluate_now (tmp, &block);
2198 }
2199 }
2200 gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2201
2202 tmp = gfc_finish_block (&block);
2203 gfc_add_expr_to_block (&loop->pre, tmp);
2204 }
2205}
2206
2207
13795658 2208/* Return true if the two SS could be aliased, i.e. both point to the same data
6de9cd9a
DN		 2209 object. */
2210/* TODO: resolve aliases based on frontend expressions. */
2211
2212static int
2213gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2214{
2215 gfc_ref *lref;
2216 gfc_ref *rref;
2217 gfc_symbol *lsym;
2218 gfc_symbol *rsym;
2219
2220 lsym = lss->expr->symtree->n.sym;
2221 rsym = rss->expr->symtree->n.sym;
2222 if (gfc_symbols_could_alias (lsym, rsym))
2223 return 1;
2224
2225 if (rsym->ts.type != BT_DERIVED
2226 && lsym->ts.type != BT_DERIVED)
2227 return 0;
2228
13413760 2229 /* For derived types we must check all the component types. We can ignore
6de9cd9a
DN		 2230 array references as these will have the same base type as the previous
2231 component ref. */
2232 for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2233 {
2234 if (lref->type != REF_COMPONENT)
2235 continue;
2236
2237 if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2238 return 1;
2239
2240 for (rref = rss->expr->ref; rref != rss->data.info.ref;
2241 rref = rref->next)
2242 {
2243 if (rref->type != REF_COMPONENT)
2244 continue;
2245
2246 if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2247 return 1;
2248 }
2249 }
2250
2251 for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2252 {
2253 if (rref->type != REF_COMPONENT)
2254 break;
2255
2256 if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2257 return 1;
2258 }
2259
2260 return 0;
2261}
2262
2263
2264/* Resolve array data dependencies. Creates a temporary if required. */
2265/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2266 dependency.c. */
2267
2268void
2269gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2270 gfc_ss * rss)
2271{
2272 gfc_ss *ss;
2273 gfc_ref *lref;
2274 gfc_ref *rref;
2275 gfc_ref *aref;
2276 int nDepend = 0;
2277 int temp_dim = 0;
2278
2279 loop->temp_ss = NULL;
2280 aref = dest->data.info.ref;
2281 temp_dim = 0;
2282
2283 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2284 {
2285 if (ss->type != GFC_SS_SECTION)
2286 continue;
2287
2288 if (gfc_could_be_alias (dest, ss))
2289 {
2290 nDepend = 1;
2291 break;
2292 }
2293
2294 if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2295 {
2296 lref = dest->expr->ref;
2297 rref = ss->expr->ref;
2298
2299 nDepend = gfc_dep_resolver (lref, rref);
2300#if 0
2301 /* TODO : loop shifting. */
2302 if (nDepend == 1)
2303 {
2304 /* Mark the dimensions for LOOP SHIFTING */
2305 for (n = 0; n < loop->dimen; n++)
2306 {
2307 int dim = dest->data.info.dim[n];
2308
2309 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2310 depends[n] = 2;
2311 else if (! gfc_is_same_range (&lref->u.ar,
2312 &rref->u.ar, dim, 0))
2313 depends[n] = 1;
2314 }
2315
13413760 2316 /* Put all the dimensions with dependencies in the
6de9cd9a
DN		 2317 innermost loops. */
2318 dim = 0;
2319 for (n = 0; n < loop->dimen; n++)
2320 {
6e45f57b 2321 gcc_assert (loop->order[n] == n);
6de9cd9a
DN		 2322 if (depends[n])
2323 loop->order[dim++] = n;
2324 }
2325 temp_dim = dim;
2326 for (n = 0; n < loop->dimen; n++)
2327 {
2328 if (! depends[n])
2329 loop->order[dim++] = n;
2330 }
2331
6e45f57b 2332 gcc_assert (dim == loop->dimen);
6de9cd9a
DN		 2333 break;
2334 }
2335#endif
2336 }
2337 }
2338
2339 if (nDepend == 1)
2340 {
2341 loop->temp_ss = gfc_get_ss ();
2342 loop->temp_ss->type = GFC_SS_TEMP;
2343 loop->temp_ss->data.temp.type =
2344 gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
40f20186 2345 loop->temp_ss->string_length = NULL_TREE;
6de9cd9a
DN		 2346 loop->temp_ss->data.temp.dimen = loop->dimen;
2347 loop->temp_ss->next = gfc_ss_terminator;
2348 gfc_add_ss_to_loop (loop, loop->temp_ss);
2349 }
2350 else
2351 loop->temp_ss = NULL;
2352}
2353
2354
1f2959f0 2355/* Initialize the scalarization loop. Creates the loop variables. Determines
6de9cd9a
DN		 2356 the range of the loop variables. Creates a temporary if required.
2357 Calculates how to transform from loop variables to array indices for each
2358 expression. Also generates code for scalar expressions which have been
f7b529fa 2359 moved outside the loop. */
6de9cd9a
DN		 2360
2361void
2362gfc_conv_loop_setup (gfc_loopinfo * loop)
2363{
2364 int n;
2365 int dim;
2366 gfc_ss_info *info;
2367 gfc_ss_info *specinfo;
2368 gfc_ss *ss;
2369 tree tmp;
2370 tree len;
2371 gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2372 mpz_t *cshape;
2373 mpz_t i;
2374
2375 mpz_init (i);
2376 for (n = 0; n < loop->dimen; n++)
2377 {
2378 loopspec[n] = NULL;
2379 /* We use one SS term, and use that to determine the bounds of the
2380 loop for this dimension. We try to pick the simplest term. */
2381 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2382 {
e9cfef64 2383 if (ss->shape)
6de9cd9a
DN		 2384 {
2385 /* The frontend has worked out the size for us. */
2386 loopspec[n] = ss;
2387 continue;
2388 }
2389
2390 if (ss->type == GFC_SS_CONSTRUCTOR)
2391 {
e9cfef64 2392 /* An unknown size constructor will always be rank one.
40f20186 2393 Higher rank constructors will either have known shape,
e9cfef64 2394 or still be wrapped in a call to reshape. */
6e45f57b 2395 gcc_assert (loop->dimen == 1);
13413760
TS		 2396 /* Try to figure out the size of the constructor. */
2397 /* TODO: avoid this by making the frontend set the shape. */
6de9cd9a 2398 gfc_get_array_cons_size (&i, ss->expr->value.constructor);
f7b529fa 2399 /* A negative value means we failed. */
6de9cd9a
DN		 2400 if (mpz_sgn (i) > 0)
2401 {
2402 mpz_sub_ui (i, i, 1);
2403 loop->to[n] =
2404 gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2405 loopspec[n] = ss;
2406 }
2407 continue;
2408 }
2409
fc90a8f2 2410 /* TODO: Pick the best bound if we have a choice between a
e9cfef64 2411 function and something else. */
fc90a8f2
PB		 2412 if (ss->type == GFC_SS_FUNCTION)
2413 {
2414 loopspec[n] = ss;
2415 continue;
2416 }
2417
6de9cd9a
DN		 2418 if (ss->type != GFC_SS_SECTION)
2419 continue;
2420
6de9cd9a
DN		 2421 if (loopspec[n])
2422 specinfo = &loopspec[n]->data.info;
2423 else
2424 specinfo = NULL;
2425 info = &ss->data.info;
2426
2427 /* Criteria for choosing a loop specifier (most important first):
2428 stride of one
2429 known stride
2430 known lower bound
2431 known upper bound
2432 */
2433 if (!specinfo)
2434 loopspec[n] = ss;
40f20186 2435 /* TODO: Is != constructor correct? */
6de9cd9a
DN		 2436 else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
2437 {
2438 if (integer_onep (info->stride[n])
2439 && !integer_onep (specinfo->stride[n]))
2440 loopspec[n] = ss;
2441 else if (INTEGER_CST_P (info->stride[n])
2442 && !INTEGER_CST_P (specinfo->stride[n]))
2443 loopspec[n] = ss;
2444 else if (INTEGER_CST_P (info->start[n])
2445 && !INTEGER_CST_P (specinfo->start[n]))
2446 loopspec[n] = ss;
2447 /* We don't work out the upper bound.
2448 else if (INTEGER_CST_P (info->finish[n])
2449 && ! INTEGER_CST_P (specinfo->finish[n]))
2450 loopspec[n] = ss; */
2451 }
2452 }
2453
2454 if (!loopspec[n])
2455 gfc_todo_error ("Unable to find scalarization loop specifier");
2456
2457 info = &loopspec[n]->data.info;
2458
2459 /* Set the extents of this range. */
e9cfef64 2460 cshape = loopspec[n]->shape;
6de9cd9a
DN		 2461 if (cshape && INTEGER_CST_P (info->start[n])
2462 && INTEGER_CST_P (info->stride[n]))
2463 {
2464 loop->from[n] = info->start[n];
2465 mpz_set (i, cshape[n]);
2466 mpz_sub_ui (i, i, 1);
2467 /* To = from + (size - 1) * stride. */
2468 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2469 if (!integer_onep (info->stride[n]))
10c7a96f
SB		 2470 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2471 tmp, info->stride[n]);
2472 loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2473 loop->from[n], tmp);
6de9cd9a
DN		 2474 }
2475 else
2476 {
2477 loop->from[n] = info->start[n];
2478 switch (loopspec[n]->type)
2479 {
2480 case GFC_SS_CONSTRUCTOR:
6e45f57b
PB		 2481 gcc_assert (info->dimen == 1);
2482 gcc_assert (loop->to[n]);
6de9cd9a
DN		 2483 break;
2484
2485 case GFC_SS_SECTION:
2486 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2487 &loop->pre);
2488 break;
2489
fc90a8f2
PB		 2490 case GFC_SS_FUNCTION:
2491 /* The loop bound will be set when we generate the call. */
6e45f57b 2492 gcc_assert (loop->to[n] == NULL_TREE);
fc90a8f2
PB		 2493 break;
2494
6de9cd9a 2495 default:
6e45f57b 2496 gcc_unreachable ();
6de9cd9a
DN		 2497 }
2498 }
2499
2500 /* Transform everything so we have a simple incrementing variable. */
2501 if (integer_onep (info->stride[n]))
7ab92584 2502 info->delta[n] = gfc_index_zero_node;
6de9cd9a
DN		 2503 else
2504 {
2505 /* Set the delta for this section. */
2506 info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2507 /* Number of iterations is (end - start + step) / step.
2508 with start = 0, this simplifies to
2509 last = end / step;
2510 for (i = 0; i<=last; i++){...}; */
10c7a96f
SB		 2511 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2512 loop->to[n], loop->from[n]);
2513 tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
2514 tmp, info->stride[n]);
6de9cd9a
DN		 2515 loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2516 /* Make the loop variable start at 0. */
7ab92584 2517 loop->from[n] = gfc_index_zero_node;
6de9cd9a
DN		 2518 }
2519 }
2520
fc90a8f2
PB		 2521 /* Add all the scalar code that can be taken out of the loops.
2522 This may include calculating the loop bounds, so do it before
2523 allocating the temporary. */
2524 gfc_add_loop_ss_code (loop, loop->ss, false);
2525
6de9cd9a
DN		 2526 /* If we want a temporary then create it. */
2527 if (loop->temp_ss != NULL)
2528 {
6e45f57b 2529 gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
6de9cd9a 2530 tmp = loop->temp_ss->data.temp.type;
40f20186 2531 len = loop->temp_ss->string_length;
6de9cd9a
DN		 2532 n = loop->temp_ss->data.temp.dimen;
2533 memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2534 loop->temp_ss->type = GFC_SS_SECTION;
2535 loop->temp_ss->data.info.dimen = n;
40f20186 2536 gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
6de9cd9a
DN		 2537 }
2538
6de9cd9a
DN		 2539 for (n = 0; n < loop->temp_dim; n++)
2540 loopspec[loop->order[n]] = NULL;
2541
2542 mpz_clear (i);
2543
2544 /* For array parameters we don't have loop variables, so don't calculate the
2545 translations. */
2546 if (loop->array_parameter)
2547 return;
2548
2549 /* Calculate the translation from loop variables to array indices. */
2550 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2551 {
e9cfef64 2552 if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
6de9cd9a
DN		 2553 continue;
2554
2555 info = &ss->data.info;
2556
2557 for (n = 0; n < info->dimen; n++)
2558 {
2559 dim = info->dim[n];
2560
e9cfef64 2561 /* If we are specifying the range the delta is already set. */
6de9cd9a
DN		 2562 if (loopspec[n] != ss)
2563 {
2564 /* Calculate the offset relative to the loop variable.
2565 First multiply by the stride. */
10c7a96f
SB		 2566 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2567 loop->from[n], info->stride[n]);
6de9cd9a
DN		 2568
2569 /* Then subtract this from our starting value. */
10c7a96f
SB		 2570 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2571 info->start[n], tmp);
6de9cd9a
DN		 2572
2573 info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2574 }
2575 }
2576 }
2577}
2578
2579
2580/* Fills in an array descriptor, and returns the size of the array. The size
2581 will be a simple_val, ie a variable or a constant. Also calculates the
1f2959f0 2582 offset of the base. Returns the size of the array.
6de9cd9a
DN		 2583 {
2584 stride = 1;
2585 offset = 0;
2586 for (n = 0; n < rank; n++)
2587 {
2588 a.lbound[n] = specified_lower_bound;
2589 offset = offset + a.lbond[n] * stride;
2590 size = 1 - lbound;
2591 a.ubound[n] = specified_upper_bound;
2592 a.stride[n] = stride;
2593 size = ubound + size; //size = ubound + 1 - lbound
2594 stride = stride * size;
2595 }
2596 return (stride);
2597 } */
2598/*GCC ARRAYS*/
2599
2600static tree
2601gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2602 gfc_expr ** lower, gfc_expr ** upper,
2603 stmtblock_t * pblock)
2604{
2605 tree type;
2606 tree tmp;
2607 tree size;
2608 tree offset;
2609 tree stride;
2610 gfc_expr *ubound;
2611 gfc_se se;
2612 int n;
2613
2614 type = TREE_TYPE (descriptor);
2615
7ab92584
SB		 2616 stride = gfc_index_one_node;
2617 offset = gfc_index_zero_node;
6de9cd9a
DN		 2618
2619 /* Set the dtype. */
2620 tmp = gfc_conv_descriptor_dtype (descriptor);
40b026d8 2621 gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
6de9cd9a
DN		 2622
2623 for (n = 0; n < rank; n++)
2624 {
2625 /* We have 3 possibilities for determining the size of the array:
2626 lower == NULL => lbound = 1, ubound = upper[n]
2627 upper[n] = NULL => lbound = 1, ubound = lower[n]
2628 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
2629 ubound = upper[n];
2630
2631 /* Set lower bound. */
2632 gfc_init_se (&se, NULL);
2633 if (lower == NULL)
7ab92584 2634 se.expr = gfc_index_one_node;
6de9cd9a
DN		 2635 else
2636 {
6e45f57b 2637 gcc_assert (lower[n]);
6de9cd9a
DN		 2638 if (ubound)
2639 {
2640 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2641 gfc_add_block_to_block (pblock, &se.pre);
2642 }
2643 else
2644 {
7ab92584 2645 se.expr = gfc_index_one_node;
6de9cd9a
DN		 2646 ubound = lower[n];
2647 }
2648 }
2649 tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2650 gfc_add_modify_expr (pblock, tmp, se.expr);
2651
2652 /* Work out the offset for this component. */
10c7a96f
SB		 2653 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2654 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
6de9cd9a
DN		 2655
2656 /* Start the calculation for the size of this dimension. */
923ab88c
TS		 2657 size = build2 (MINUS_EXPR, gfc_array_index_type,
2658 gfc_index_one_node, se.expr);
6de9cd9a
DN		 2659
2660 /* Set upper bound. */
2661 gfc_init_se (&se, NULL);
6e45f57b 2662 gcc_assert (ubound);
6de9cd9a
DN		 2663 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2664 gfc_add_block_to_block (pblock, &se.pre);
2665
2666 tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2667 gfc_add_modify_expr (pblock, tmp, se.expr);
2668
2669 /* Store the stride. */
2670 tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2671 gfc_add_modify_expr (pblock, tmp, stride);
2672
2673 /* Calculate the size of this dimension. */
10c7a96f 2674 size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
6de9cd9a
DN		 2675
2676 /* Multiply the stride by the number of elements in this dimension. */
10c7a96f 2677 stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
6de9cd9a
DN		 2678 stride = gfc_evaluate_now (stride, pblock);
2679 }
2680
2681 /* The stride is the number of elements in the array, so multiply by the
2682 size of an element to get the total size. */
2683 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10c7a96f 2684 size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
6de9cd9a
DN		 2685
2686 if (poffset != NULL)
2687 {
2688 offset = gfc_evaluate_now (offset, pblock);
2689 *poffset = offset;
2690 }
2691
2692 size = gfc_evaluate_now (size, pblock);
2693 return size;
2694}
2695
2696
1f2959f0 2697/* Initializes the descriptor and generates a call to _gfor_allocate. Does
6de9cd9a
DN		 2698 the work for an ALLOCATE statement. */
2699/*GCC ARRAYS*/
2700
2701void
2702gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2703{
2704 tree tmp;
2705 tree pointer;
2706 tree allocate;
2707 tree offset;
2708 tree size;
2709 gfc_expr **lower;
2710 gfc_expr **upper;
2711
2712 /* Figure out the size of the array. */
2713 switch (ref->u.ar.type)
2714 {
2715 case AR_ELEMENT:
2716 lower = NULL;
2717 upper = ref->u.ar.start;
2718 break;
2719
2720 case AR_FULL:
6e45f57b 2721 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
6de9cd9a
DN		 2722
2723 lower = ref->u.ar.as->lower;
2724 upper = ref->u.ar.as->upper;
2725 break;
2726
2727 case AR_SECTION:
2728 lower = ref->u.ar.start;
2729 upper = ref->u.ar.end;
2730 break;
2731
2732 default:
6e45f57b 2733 gcc_unreachable ();
6de9cd9a
DN		 2734 break;
2735 }
2736
2737 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2738 lower, upper, &se->pre);
2739
2740 /* Allocate memory to store the data. */
2741 tmp = gfc_conv_descriptor_data (se->expr);
2742 pointer = gfc_build_addr_expr (NULL, tmp);
2743 pointer = gfc_evaluate_now (pointer, &se->pre);
2744
e2cad04b 2745 if (TYPE_PRECISION (gfc_array_index_type) == 32)
6de9cd9a 2746 allocate = gfor_fndecl_allocate;
e2cad04b 2747 else if (TYPE_PRECISION (gfc_array_index_type) == 64)
6de9cd9a
DN		 2748 allocate = gfor_fndecl_allocate64;
2749 else
6e45f57b 2750 gcc_unreachable ();
6de9cd9a
DN		 2751
2752 tmp = gfc_chainon_list (NULL_TREE, pointer);
2753 tmp = gfc_chainon_list (tmp, size);
2754 tmp = gfc_chainon_list (tmp, pstat);
2755 tmp = gfc_build_function_call (allocate, tmp);
2756 gfc_add_expr_to_block (&se->pre, tmp);
2757
2758 pointer = gfc_conv_descriptor_data (se->expr);
2759
2760 tmp = gfc_conv_descriptor_offset (se->expr);
2761 gfc_add_modify_expr (&se->pre, tmp, offset);
2762}
2763
2764
2765/* Deallocate an array variable. Also used when an allocated variable goes
2766 out of scope. */
2767/*GCC ARRAYS*/
2768
2769tree
2770gfc_array_deallocate (tree descriptor)
2771{
2772 tree var;
2773 tree tmp;
2774 stmtblock_t block;
2775
2776 gfc_start_block (&block);
2777 /* Get a pointer to the data. */
2778 tmp = gfc_conv_descriptor_data (descriptor);
2779 tmp = gfc_build_addr_expr (NULL, tmp);
2780 var = gfc_create_var (TREE_TYPE (tmp), "ptr");
2781 gfc_add_modify_expr (&block, var, tmp);
2782
2783 /* Parameter is the address of the data component. */
2784 tmp = gfc_chainon_list (NULL_TREE, var);
2785 tmp = gfc_chainon_list (tmp, integer_zero_node);
2786 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2787 gfc_add_expr_to_block (&block, tmp);
2788
2789 return gfc_finish_block (&block);
2790}
2791
2792
2793/* Create an array constructor from an initialization expression.
2794 We assume the frontend already did any expansions and conversions. */
2795
2796tree
2797gfc_conv_array_initializer (tree type, gfc_expr * expr)
2798{
2799 gfc_constructor *c;
2800 tree list;
2801 tree tmp;
2802 mpz_t maxval;
2803 gfc_se se;
2804 HOST_WIDE_INT hi;
2805 unsigned HOST_WIDE_INT lo;
2806 tree index, range;
2807
2808 list = NULL_TREE;
2809 switch (expr->expr_type)
2810 {
2811 case EXPR_CONSTANT:
2812 case EXPR_STRUCTURE:
2813 /* A single scalar or derived type value. Create an array with all
2814 elements equal to that value. */
2815 gfc_init_se (&se, NULL);
e9cfef64
PB		 2816
2817 if (expr->expr_type == EXPR_CONSTANT)
2818 gfc_conv_constant (&se, expr);
2819 else
2820 gfc_conv_structure (&se, expr, 1);
6de9cd9a
DN		 2821
2822 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6e45f57b 2823 gcc_assert (tmp && INTEGER_CST_P (tmp));
6de9cd9a
DN		 2824 hi = TREE_INT_CST_HIGH (tmp);
2825 lo = TREE_INT_CST_LOW (tmp);
2826 lo++;
2827 if (lo == 0)
2828 hi++;
2829 /* This will probably eat buckets of memory for large arrays. */
2830 while (hi != 0 || lo != 0)
2831 {
2832 list = tree_cons (NULL_TREE, se.expr, list);
2833 if (lo == 0)
2834 hi--;
2835 lo--;
2836 }
2837 break;
2838
2839 case EXPR_ARRAY:
2840 /* Create a list of all the elements. */
2841 for (c = expr->value.constructor; c; c = c->next)
2842 {
2843 if (c->iterator)
2844 {
2845 /* Problems occur when we get something like
2846 integer :: a(lots) = (/(i, i=1,lots)/) */
2847 /* TODO: Unexpanded array initializers. */
2848 internal_error
2849 ("Possible frontend bug: array constructor not expanded");
2850 }
2851 if (mpz_cmp_si (c->n.offset, 0) != 0)
2852 index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2853 else
2854 index = NULL_TREE;
2855 mpz_init (maxval);
2856 if (mpz_cmp_si (c->repeat, 0) != 0)
2857 {
2858 tree tmp1, tmp2;
2859
2860 mpz_set (maxval, c->repeat);
2861 mpz_add (maxval, c->n.offset, maxval);
2862 mpz_sub_ui (maxval, maxval, 1);
2863 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2864 if (mpz_cmp_si (c->n.offset, 0) != 0)
2865 {
2866 mpz_add_ui (maxval, c->n.offset, 1);
2867 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
2868 }
2869 else
2870 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
2871
923ab88c 2872 range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
6de9cd9a
DN		 2873 }
2874 else
2875 range = NULL;
2876 mpz_clear (maxval);
2877
2878 gfc_init_se (&se, NULL);
2879 switch (c->expr->expr_type)
2880 {
2881 case EXPR_CONSTANT:
2882 gfc_conv_constant (&se, c->expr);
2883 if (range == NULL_TREE)
2884 list = tree_cons (index, se.expr, list);
2885 else
2886 {
2887 if (index != NULL_TREE)
2888 list = tree_cons (index, se.expr, list);
2889 list = tree_cons (range, se.expr, list);
2890 }
2891 break;
2892
2893 case EXPR_STRUCTURE:
2894 gfc_conv_structure (&se, c->expr, 1);
2895 list = tree_cons (index, se.expr, list);
2896 break;
2897
2898 default:
6e45f57b 2899 gcc_unreachable ();
6de9cd9a
DN		 2900 }
2901 }
2902 /* We created the list in reverse order. */
2903 list = nreverse (list);
2904 break;
2905
2906 default:
6e45f57b 2907 gcc_unreachable ();
6de9cd9a
DN		 2908 }
2909
2910 /* Create a constructor from the list of elements. */
2911 tmp = build1 (CONSTRUCTOR, type, list);
2912 TREE_CONSTANT (tmp) = 1;
2913 TREE_INVARIANT (tmp) = 1;
2914 return tmp;
2915}
2916
2917
2918/* Generate code to evaluate non-constant array bounds. Sets *poffset and
2919 returns the size (in elements) of the array. */
2920
2921static tree
2922gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
2923 stmtblock_t * pblock)
2924{
2925 gfc_array_spec *as;
2926 tree size;
2927 tree stride;
2928 tree offset;
2929 tree ubound;
2930 tree lbound;
2931 tree tmp;
2932 gfc_se se;
2933
2934 int dim;
2935
2936 as = sym->as;
2937
7ab92584
SB		 2938 size = gfc_index_one_node;
2939 offset = gfc_index_zero_node;
6de9cd9a
DN		 2940 for (dim = 0; dim < as->rank; dim++)
2941 {
2942 /* Evaluate non-constant array bound expressions. */
2943 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
2944 if (as->lower[dim] && !INTEGER_CST_P (lbound))
2945 {
2946 gfc_init_se (&se, NULL);
2947 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
2948 gfc_add_block_to_block (pblock, &se.pre);
2949 gfc_add_modify_expr (pblock, lbound, se.expr);
2950 }
2951 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
2952 if (as->upper[dim] && !INTEGER_CST_P (ubound))
2953 {
2954 gfc_init_se (&se, NULL);
2955 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
2956 gfc_add_block_to_block (pblock, &se.pre);
2957 gfc_add_modify_expr (pblock, ubound, se.expr);
2958 }
f7b529fa 2959 /* The offset of this dimension. offset = offset - lbound * stride. */
10c7a96f
SB		 2960 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
2961 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
6de9cd9a
DN		 2962
2963 /* The size of this dimension, and the stride of the next. */
2964 if (dim + 1 < as->rank)
2965 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
2966 else
2967 stride = NULL_TREE;
2968
2969 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
2970 {
2971 /* Calculate stride = size * (ubound + 1 - lbound). */
10c7a96f
SB		 2972 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2973 gfc_index_one_node, lbound);
2974 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
2975 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
6de9cd9a
DN		 2976 if (stride)
2977 gfc_add_modify_expr (pblock, stride, tmp);
2978 else
2979 stride = gfc_evaluate_now (tmp, pblock);
2980 }
2981
2982 size = stride;
2983 }
2984
2985 *poffset = offset;
2986 return size;
2987}
2988
2989
2990/* Generate code to initialize/allocate an array variable. */
2991
2992tree
2993gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
2994{
2995 stmtblock_t block;
2996 tree type;
2997 tree tmp;
2998 tree fndecl;
2999 tree size;
3000 tree offset;
6de9cd9a
DN		 3001 bool onstack;
3002
6e45f57b 3003 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
6de9cd9a
DN		 3004
3005 /* Do nothing for USEd variables. */
3006 if (sym->attr.use_assoc)
3007 return fnbody;
3008
3009 type = TREE_TYPE (decl);
6e45f57b 3010 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 3011 onstack = TREE_CODE (type) != POINTER_TYPE;
3012
6de9cd9a
DN		 3013 gfc_start_block (&block);
3014
3015 /* Evaluate character string length. */
3016 if (sym->ts.type == BT_CHARACTER
3017 && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3018 {
3019 gfc_trans_init_string_length (sym->ts.cl, &block);
3020
1a186ec5 3021 /* Emit a DECL_EXPR for this variable, which will cause the
13795658 3022 gimplifier to allocate storage, and all that good stuff. */
923ab88c 3023 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
6de9cd9a
DN		 3024 gfc_add_expr_to_block (&block, tmp);
3025 }
3026
3027 if (onstack)
3028 {
6de9cd9a
DN		 3029 gfc_add_expr_to_block (&block, fnbody);
3030 return gfc_finish_block (&block);
3031 }
3032
3033 type = TREE_TYPE (type);
3034
6e45f57b
PB		 3035 gcc_assert (!sym->attr.use_assoc);
3036 gcc_assert (!TREE_STATIC (decl));
cb9e4f55 3037 gcc_assert (!sym->module);
6de9cd9a
DN		 3038
3039 if (sym->ts.type == BT_CHARACTER
3040 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3041 gfc_trans_init_string_length (sym->ts.cl, &block);
3042
3043 size = gfc_trans_array_bounds (type, sym, &offset, &block);
3044
3045 /* The size is the number of elements in the array, so multiply by the
3046 size of an element to get the total size. */
3047 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10c7a96f 3048 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
6de9cd9a
DN		 3049
3050 /* Allocate memory to hold the data. */
3051 tmp = gfc_chainon_list (NULL_TREE, size);
3052
3053 if (gfc_index_integer_kind == 4)
3054 fndecl = gfor_fndecl_internal_malloc;
3055 else if (gfc_index_integer_kind == 8)
3056 fndecl = gfor_fndecl_internal_malloc64;
3057 else
6e45f57b 3058 gcc_unreachable ();
6de9cd9a
DN		 3059 tmp = gfc_build_function_call (fndecl, tmp);
3060 tmp = fold (convert (TREE_TYPE (decl), tmp));
3061 gfc_add_modify_expr (&block, decl, tmp);
3062
3063 /* Set offset of the array. */
3064 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3065 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3066
3067
3068 /* Automatic arrays should not have initializers. */
6e45f57b 3069 gcc_assert (!sym->value);
6de9cd9a
DN		 3070
3071 gfc_add_expr_to_block (&block, fnbody);
3072
3073 /* Free the temporary. */
3074 tmp = convert (pvoid_type_node, decl);
3075 tmp = gfc_chainon_list (NULL_TREE, tmp);
3076 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3077 gfc_add_expr_to_block (&block, tmp);
3078
3079 return gfc_finish_block (&block);
3080}
3081
3082
3083/* Generate entry and exit code for g77 calling convention arrays. */
3084
3085tree
3086gfc_trans_g77_array (gfc_symbol * sym, tree body)
3087{
3088 tree parm;
3089 tree type;
3090 locus loc;
3091 tree offset;
3092 tree tmp;
3093 stmtblock_t block;
3094
3095 gfc_get_backend_locus (&loc);
3096 gfc_set_backend_locus (&sym->declared_at);
3097
3098 /* Descriptor type. */
3099 parm = sym->backend_decl;
3100 type = TREE_TYPE (parm);
6e45f57b 3101 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 3102
3103 gfc_start_block (&block);
3104
3105 if (sym->ts.type == BT_CHARACTER
20c9dc8a 3106 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
6de9cd9a
DN		 3107 gfc_trans_init_string_length (sym->ts.cl, &block);
3108
3109 /* Evaluate the bounds of the array. */
3110 gfc_trans_array_bounds (type, sym, &offset, &block);
3111
3112 /* Set the offset. */
3113 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3114 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3115
1f2959f0 3116 /* Set the pointer itself if we aren't using the parameter directly. */
6de9cd9a
DN		 3117 if (TREE_CODE (parm) != PARM_DECL)
3118 {
3119 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3120 gfc_add_modify_expr (&block, parm, tmp);
3121 }
3122 tmp = gfc_finish_block (&block);
3123
3124 gfc_set_backend_locus (&loc);
3125
3126 gfc_start_block (&block);
3127 /* Add the initialization code to the start of the function. */
3128 gfc_add_expr_to_block (&block, tmp);
3129 gfc_add_expr_to_block (&block, body);
3130
3131 return gfc_finish_block (&block);
3132}
3133
3134
3135/* Modify the descriptor of an array parameter so that it has the
3136 correct lower bound. Also move the upper bound accordingly.
3137 If the array is not packed, it will be copied into a temporary.
3138 For each dimension we set the new lower and upper bounds. Then we copy the
3139 stride and calculate the offset for this dimension. We also work out
3140 what the stride of a packed array would be, and see it the two match.
3141 If the array need repacking, we set the stride to the values we just
3142 calculated, recalculate the offset and copy the array data.
3143 Code is also added to copy the data back at the end of the function.
3144 */
3145
3146tree
3147gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3148{
3149 tree size;
3150 tree type;
3151 tree offset;
3152 locus loc;
3153 stmtblock_t block;
3154 stmtblock_t cleanup;
3155 tree lbound;
3156 tree ubound;
3157 tree dubound;
3158 tree dlbound;
3159 tree dumdesc;
3160 tree tmp;
3161 tree stmt;
3162 tree stride;
3163 tree stmt_packed;
3164 tree stmt_unpacked;
3165 tree partial;
3166 gfc_se se;
3167 int n;
3168 int checkparm;
3169 int no_repack;
3d79abbd 3170 bool optional_arg;
6de9cd9a 3171
fc90a8f2
PB		 3172 /* Do nothing for pointer and allocatable arrays. */
3173 if (sym->attr.pointer || sym->attr.allocatable)
3174 return body;
3175
6de9cd9a
DN		 3176 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3177 return gfc_trans_g77_array (sym, body);
3178
3179 gfc_get_backend_locus (&loc);
3180 gfc_set_backend_locus (&sym->declared_at);
3181
3182 /* Descriptor type. */
3183 type = TREE_TYPE (tmpdesc);
6e45f57b 3184 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 3185 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3186 dumdesc = gfc_build_indirect_ref (dumdesc);
3187 gfc_start_block (&block);
3188
3189 if (sym->ts.type == BT_CHARACTER
20c9dc8a 3190 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
6de9cd9a
DN		 3191 gfc_trans_init_string_length (sym->ts.cl, &block);
3192
3193 checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3194
3195 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3196 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3197
3198 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3199 {
3200 /* For non-constant shape arrays we only check if the first dimension
3201 is contiguous. Repacking higher dimensions wouldn't gain us
3202 anything as we still don't know the array stride. */
3203 partial = gfc_create_var (boolean_type_node, "partial");
3204 TREE_USED (partial) = 1;
3205 tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
10c7a96f 3206 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
6de9cd9a
DN		 3207 gfc_add_modify_expr (&block, partial, tmp);
3208 }
3209 else
3210 {
3211 partial = NULL_TREE;
3212 }
3213
3214 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3215 here, however I think it does the right thing. */
3216 if (no_repack)
3217 {
3218 /* Set the first stride. */
3219 stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3220 stride = gfc_evaluate_now (stride, &block);
3221
923ab88c
TS		 3222 tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3223 tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3224 gfc_index_one_node, stride);
6de9cd9a
DN		 3225 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3226 gfc_add_modify_expr (&block, stride, tmp);
3227
3228 /* Allow the user to disable array repacking. */
3229 stmt_unpacked = NULL_TREE;
3230 }
3231 else
3232 {
6e45f57b 3233 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
1f2959f0 3234 /* A library call to repack the array if necessary. */
6de9cd9a
DN		 3235 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3236 tmp = gfc_chainon_list (NULL_TREE, tmp);
3237 stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3238
7ab92584 3239 stride = gfc_index_one_node;
6de9cd9a
DN		 3240 }
3241
3242 /* This is for the case where the array data is used directly without
3243 calling the repack function. */
3244 if (no_repack || partial != NULL_TREE)
3245 stmt_packed = gfc_conv_descriptor_data (dumdesc);
3246 else
3247 stmt_packed = NULL_TREE;
3248
3249 /* Assign the data pointer. */
3250 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3251 {
3252 /* Don't repack unknown shape arrays when the first stride is 1. */
923ab88c
TS		 3253 tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3254 stmt_packed, stmt_unpacked);
6de9cd9a
DN		 3255 }
3256 else
3257 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7ab92584 3258 gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
6de9cd9a 3259
7ab92584
SB		 3260 offset = gfc_index_zero_node;
3261 size = gfc_index_one_node;
6de9cd9a
DN		 3262
3263 /* Evaluate the bounds of the array. */
3264 for (n = 0; n < sym->as->rank; n++)
3265 {
3266 if (checkparm || !sym->as->upper[n])
3267 {
3268 /* Get the bounds of the actual parameter. */
3269 dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3270 dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3271 }
3272 else
3273 {
3274 dubound = NULL_TREE;
3275 dlbound = NULL_TREE;
3276 }
3277
3278 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
3279 if (!INTEGER_CST_P (lbound))
3280 {
3281 gfc_init_se (&se, NULL);
3282 gfc_conv_expr_type (&se, sym->as->upper[n],
3283 gfc_array_index_type);
3284 gfc_add_block_to_block (&block, &se.pre);
3285 gfc_add_modify_expr (&block, lbound, se.expr);
3286 }
3287
3288 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
3289 /* Set the desired upper bound. */
3290 if (sym->as->upper[n])
3291 {
3292 /* We know what we want the upper bound to be. */
3293 if (!INTEGER_CST_P (ubound))
3294 {
3295 gfc_init_se (&se, NULL);
3296 gfc_conv_expr_type (&se, sym->as->upper[n],
3297 gfc_array_index_type);
3298 gfc_add_block_to_block (&block, &se.pre);
3299 gfc_add_modify_expr (&block, ubound, se.expr);
3300 }
3301
3302 /* Check the sizes match. */
3303 if (checkparm)
3304 {
3305 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
3306
10c7a96f
SB		 3307 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3308 ubound, lbound);
923ab88c
TS		 3309 stride = build2 (MINUS_EXPR, gfc_array_index_type,
3310 dubound, dlbound);
10c7a96f 3311 tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride);
6de9cd9a
DN		 3312 gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
3313 }
3314 }
3315 else
3316 {
3317 /* For assumed shape arrays move the upper bound by the same amount
3318 as the lower bound. */
923ab88c 3319 tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
10c7a96f 3320 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
6de9cd9a
DN		 3321 gfc_add_modify_expr (&block, ubound, tmp);
3322 }
f7b529fa 3323 /* The offset of this dimension. offset = offset - lbound * stride. */
10c7a96f
SB		 3324 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
3325 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
6de9cd9a
DN		 3326
3327 /* The size of this dimension, and the stride of the next. */
3328 if (n + 1 < sym->as->rank)
3329 {
3330 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
3331
3332 if (no_repack || partial != NULL_TREE)
3333 {
3334 stmt_unpacked =
3335 gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
3336 }
3337
3338 /* Figure out the stride if not a known constant. */
3339 if (!INTEGER_CST_P (stride))
3340 {
3341 if (no_repack)
3342 stmt_packed = NULL_TREE;
3343 else
3344 {
3345 /* Calculate stride = size * (ubound + 1 - lbound). */
10c7a96f
SB		 3346 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3347 gfc_index_one_node, lbound);
3348 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3349 ubound, tmp);
3350 size = fold_build2 (MULT_EXPR, gfc_array_index_type,
3351 size, tmp);
6de9cd9a
DN		 3352 stmt_packed = size;
3353 }
3354
3355 /* Assign the stride. */
3356 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
923ab88c
TS		 3357 tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
3358 stmt_unpacked, stmt_packed);
6de9cd9a
DN		 3359 else
3360 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
3361 gfc_add_modify_expr (&block, stride, tmp);
3362 }
3363 }
3364 }
3365
3366 /* Set the offset. */
3367 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3368 gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3369
3370 stmt = gfc_finish_block (&block);
3371
3372 gfc_start_block (&block);
3373
3374 /* Only do the entry/initialization code if the arg is present. */
3375 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3d79abbd
PB		 3376 optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
3377 if (optional_arg)
6de9cd9a
DN		 3378 {
3379 tmp = gfc_conv_expr_present (sym);
923ab88c 3380 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
6de9cd9a
DN		 3381 }
3382 gfc_add_expr_to_block (&block, stmt);
3383
3384 /* Add the main function body. */
3385 gfc_add_expr_to_block (&block, body);
3386
3387 /* Cleanup code. */
3388 if (!no_repack)
3389 {
3390 gfc_start_block (&cleanup);
3391
3392 if (sym->attr.intent != INTENT_IN)
3393 {
3394 /* Copy the data back. */
3395 tmp = gfc_chainon_list (NULL_TREE, dumdesc);
3396 tmp = gfc_chainon_list (tmp, tmpdesc);
3397 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3398 gfc_add_expr_to_block (&cleanup, tmp);
3399 }
3400
3401 /* Free the temporary. */
3402 tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
3403 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3404 gfc_add_expr_to_block (&cleanup, tmp);
3405
3406 stmt = gfc_finish_block (&cleanup);
3407
3408 /* Only do the cleanup if the array was repacked. */
3409 tmp = gfc_build_indirect_ref (dumdesc);
3410 tmp = gfc_conv_descriptor_data (tmp);
923ab88c
TS		 3411 tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
3412 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
6de9cd9a 3413
3d79abbd 3414 if (optional_arg)
6de9cd9a
DN		 3415 {
3416 tmp = gfc_conv_expr_present (sym);
923ab88c 3417 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
6de9cd9a
DN		 3418 }
3419 gfc_add_expr_to_block (&block, stmt);
3420 }
3421 /* We don't need to free any memory allocated by internal_pack as it will
3422 be freed at the end of the function by pop_context. */
3423 return gfc_finish_block (&block);
3424}
3425
3426
7ab92584
SB		 3427/* Convert an array for passing as an actual parameter. Expressions and
3428 vector subscripts are evaluated and stored in a temporary, which is then
6de9cd9a
DN		 3429 passed. For whole arrays the descriptor is passed. For array sections
3430 a modified copy of the descriptor is passed, but using the original data.
3431 Also used for array pointer assignments by setting se->direct_byref. */
3432
3433void
3434gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
3435{
3436 gfc_loopinfo loop;
3437 gfc_ss *secss;
3438 gfc_ss_info *info;
3439 int need_tmp;
3440 int n;
3441 tree tmp;
3442 tree desc;
3443 stmtblock_t block;
3444 tree start;
3445 tree offset;
3446 int full;
fc90a8f2 3447 gfc_ss *vss;
ca2940c3 3448 gfc_ref *ref;
6de9cd9a 3449
6e45f57b 3450 gcc_assert (ss != gfc_ss_terminator);
6de9cd9a
DN		 3451
3452 /* TODO: Pass constant array constructors without a temporary. */
fc90a8f2
PB		 3453 /* Special case things we know we can pass easily. */
3454 switch (expr->expr_type)
6de9cd9a 3455 {
fc90a8f2
PB		 3456 case EXPR_VARIABLE:
3457 /* If we have a linear array section, we can pass it directly.
3458 Otherwise we need to copy it into a temporary. */
6de9cd9a
DN		 3459
3460 /* Find the SS for the array section. */
3461 secss = ss;
3462 while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
3463 secss = secss->next;
3464
6e45f57b 3465 gcc_assert (secss != gfc_ss_terminator);
6de9cd9a
DN		 3466
3467 need_tmp = 0;
3468 for (n = 0; n < secss->data.info.dimen; n++)
3469 {
3470 vss = secss->data.info.subscript[secss->data.info.dim[n]];
3471 if (vss && vss->type == GFC_SS_VECTOR)
3472 need_tmp = 1;
3473 }
3474
3475 info = &secss->data.info;
3476
3477 /* Get the descriptor for the array. */
3478 gfc_conv_ss_descriptor (&se->pre, secss, 0);
3479 desc = info->descriptor;
3480 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
3481 {
3482 /* Create a new descriptor if the array doesn't have one. */
3483 full = 0;
3484 }
3485 else if (info->ref->u.ar.type == AR_FULL)
3486 full = 1;
3487 else if (se->direct_byref)
3488 full = 0;
3489 else
3490 {
ca2940c3
TS		 3491 ref = info->ref;
3492 gcc_assert (ref->u.ar.type == AR_SECTION);
6de9cd9a
DN		 3493
3494 full = 1;
ca2940c3 3495 for (n = 0; n < ref->u.ar.dimen; n++)
6de9cd9a
DN		 3496 {
3497 /* Detect passing the full array as a section. This could do
3498 even more checking, but it doesn't seem worth it. */
ca2940c3
TS		 3499 if (ref->u.ar.start[n]
3500 || ref->u.ar.end[n]
3501 || (ref->u.ar.stride[n]
3502 && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
6de9cd9a
DN		 3503 {
3504 full = 0;
3505 break;
3506 }
3507 }
3508 }
ca2940c3
TS		 3509
3510 /* Check for substring references. */
3511 ref = expr->ref;
3512 if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
3513 {
3514 while (ref->next)
3515 ref = ref->next;
3516 if (ref->type == REF_SUBSTRING)
3517 {
3518 /* In general character substrings need a copy. Character
3519 array strides are expressed as multiples of the element
3520 size (consistent with other array types), not in
3521 characters. */
3522 full = 0;
3523 need_tmp = 1;
3524 }
3525 }
3526
6de9cd9a
DN		 3527 if (full)
3528 {
3529 if (se->direct_byref)
3530 {
3531 /* Copy the descriptor for pointer assignments. */
3532 gfc_add_modify_expr (&se->pre, se->expr, desc);
3533 }
3534 else if (se->want_pointer)
3535 {
3536 /* We pass full arrays directly. This means that pointers and
fc90a8f2
PB		 3537 allocatable arrays should also work. */
3538 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6de9cd9a
DN		 3539 }
3540 else
3541 {
3542 se->expr = desc;
3543 }
ca2940c3 3544
20c9dc8a 3545 if (expr->ts.type == BT_CHARACTER)
ca2940c3
TS		 3546 se->string_length = gfc_get_expr_charlen (expr);
3547
6de9cd9a
DN		 3548 return;
3549 }
fc90a8f2
PB		 3550 break;
3551
3552 case EXPR_FUNCTION:
3553 /* A transformational function return value will be a temporary
3554 array descriptor. We still need to go through the scalarizer
3555 to create the descriptor. Elemental functions ar handled as
e7dc5b4f 3556 arbitrary expressions, i.e. copy to a temporary. */
fc90a8f2
PB		 3557 secss = ss;
3558 /* Look for the SS for this function. */
3559 while (secss != gfc_ss_terminator
3560 && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
3561 secss = secss->next;
3562
3563 if (se->direct_byref)
3564 {
6e45f57b 3565 gcc_assert (secss != gfc_ss_terminator);
fc90a8f2
PB		 3566
3567 /* For pointer assignments pass the descriptor directly. */
3568 se->ss = secss;
3569 se->expr = gfc_build_addr_expr (NULL, se->expr);
3570 gfc_conv_expr (se, expr);
3571 return;
3572 }
3573
3574 if (secss == gfc_ss_terminator)
3575 {
3576 /* Elemental function. */
3577 need_tmp = 1;
3578 info = NULL;
3579 }
3580 else
3581 {
3582 /* Transformational function. */
3583 info = &secss->data.info;
3584 need_tmp = 0;
3585 }
3586 break;
3587
3588 default:
3589 /* Something complicated. Copy it into a temporary. */
6de9cd9a
DN		 3590 need_tmp = 1;
3591 secss = NULL;
3592 info = NULL;
fc90a8f2 3593 break;
6de9cd9a
DN		 3594 }
3595
fc90a8f2 3596
6de9cd9a
DN		 3597 gfc_init_loopinfo (&loop);
3598
3599 /* Associate the SS with the loop. */
3600 gfc_add_ss_to_loop (&loop, ss);
3601
13413760 3602 /* Tell the scalarizer not to bother creating loop variables, etc. */
6de9cd9a
DN		 3603 if (!need_tmp)
3604 loop.array_parameter = 1;
3605 else
6e45f57b 3606 gcc_assert (se->want_pointer && !se->direct_byref);
6de9cd9a
DN		 3607
3608 /* Setup the scalarizing loops and bounds. */
3609 gfc_conv_ss_startstride (&loop);
3610
3611 if (need_tmp)
3612 {
3613 /* Tell the scalarizer to make a temporary. */
3614 loop.temp_ss = gfc_get_ss ();
3615 loop.temp_ss->type = GFC_SS_TEMP;
3616 loop.temp_ss->next = gfc_ss_terminator;
3617 loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
ca2940c3 3618 /* ... which can hold our string, if present. */
20c9dc8a 3619 if (expr->ts.type == BT_CHARACTER)
40f20186 3620 se->string_length = loop.temp_ss->string_length
20c9dc8a
TS		 3621 = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
3622 else
40f20186 3623 loop.temp_ss->string_length = NULL;
6de9cd9a
DN		 3624 loop.temp_ss->data.temp.dimen = loop.dimen;
3625 gfc_add_ss_to_loop (&loop, loop.temp_ss);
3626 }
3627
3628 gfc_conv_loop_setup (&loop);
3629
3630 if (need_tmp)
3631 {
3632 /* Copy into a temporary and pass that. We don't need to copy the data
3633 back because expressions and vector subscripts must be INTENT_IN. */
3634 /* TODO: Optimize passing function return values. */
3635 gfc_se lse;
3636 gfc_se rse;
3637
3638 /* Start the copying loops. */
3639 gfc_mark_ss_chain_used (loop.temp_ss, 1);
3640 gfc_mark_ss_chain_used (ss, 1);
3641 gfc_start_scalarized_body (&loop, &block);
3642
3643 /* Copy each data element. */
3644 gfc_init_se (&lse, NULL);
3645 gfc_copy_loopinfo_to_se (&lse, &loop);
3646 gfc_init_se (&rse, NULL);
3647 gfc_copy_loopinfo_to_se (&rse, &loop);
3648
3649 lse.ss = loop.temp_ss;
3650 rse.ss = ss;
3651
3652 gfc_conv_scalarized_array_ref (&lse, NULL);
3653 gfc_conv_expr_val (&rse, expr);
3654
3655 gfc_add_block_to_block (&block, &rse.pre);
3656 gfc_add_block_to_block (&block, &lse.pre);
3657
3658 gfc_add_modify_expr (&block, lse.expr, rse.expr);
3659
3660 /* Finish the copying loops. */
3661 gfc_trans_scalarizing_loops (&loop, &block);
3662
3663 /* Set the first stride component to zero to indicate a temporary. */
3664 desc = loop.temp_ss->data.info.descriptor;
3665 tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
7ab92584 3666 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
6de9cd9a 3667
6e45f57b 3668 gcc_assert (is_gimple_lvalue (desc));
6de9cd9a
DN		 3669 se->expr = gfc_build_addr_expr (NULL, desc);
3670 }
fc90a8f2
PB		 3671 else if (expr->expr_type == EXPR_FUNCTION)
3672 {
3673 desc = info->descriptor;
3674
3675 if (se->want_pointer)
3676 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
3677 else
3678 se->expr = desc;
3679
3680 if (expr->ts.type == BT_CHARACTER)
3681 se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
3682 }
6de9cd9a
DN		 3683 else
3684 {
fc90a8f2
PB		 3685 /* We pass sections without copying to a temporary. Make a new
3686 descriptor and point it at the section we want. The loop variable
3687 limits will be the limits of the section.
3688 A function may decide to repack the array to speed up access, but
3689 we're not bothered about that here. */
6de9cd9a
DN		 3690 int dim;
3691 tree parm;
3692 tree parmtype;
3693 tree stride;
3694 tree from;
3695 tree to;
3696 tree base;
3697
fc90a8f2 3698 /* Set the string_length for a character array. */
20c9dc8a 3699 if (expr->ts.type == BT_CHARACTER)
ca2940c3 3700 se->string_length = gfc_get_expr_charlen (expr);
20c9dc8a 3701
6de9cd9a 3702 desc = info->descriptor;
6e45f57b 3703 gcc_assert (secss && secss != gfc_ss_terminator);
6de9cd9a
DN		 3704 if (se->direct_byref)
3705 {
3706 /* For pointer assignments we fill in the destination. */
3707 parm = se->expr;
3708 parmtype = TREE_TYPE (parm);
3709 }
3710 else
3711 {
3712 /* Otherwise make a new one. */
3713 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3714 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
3715 loop.from, loop.to, 0);
3716 parm = gfc_create_var (parmtype, "parm");
3717 }
3718
7ab92584 3719 offset = gfc_index_zero_node;
6de9cd9a
DN		 3720 dim = 0;
3721
3722 /* The following can be somewhat confusing. We have two
3723 descriptors, a new one and the original array.
3724 {parm, parmtype, dim} refer to the new one.
3725 {desc, type, n, secss, loop} refer to the original, which maybe
3726 a descriptorless array.
e7dc5b4f 3727 The bounds of the scalarization are the bounds of the section.
6de9cd9a
DN		 3728 We don't have to worry about numeric overflows when calculating
3729 the offsets because all elements are within the array data. */
3730
3731 /* Set the dtype. */
3732 tmp = gfc_conv_descriptor_dtype (parm);
40b026d8 3733 gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
6de9cd9a
DN		 3734
3735 if (se->direct_byref)
7ab92584 3736 base = gfc_index_zero_node;
6de9cd9a
DN		 3737 else
3738 base = NULL_TREE;
3739
3740 for (n = 0; n < info->ref->u.ar.dimen; n++)
3741 {
3742 stride = gfc_conv_array_stride (desc, n);
3743
3744 /* Work out the offset. */
3745 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3746 {
6e45f57b 3747 gcc_assert (info->subscript[n]
6de9cd9a
DN		 3748 && info->subscript[n]->type == GFC_SS_SCALAR);
3749 start = info->subscript[n]->data.scalar.expr;
3750 }
3751 else
3752 {
3753 /* Check we haven't somehow got out of sync. */
6e45f57b 3754 gcc_assert (info->dim[dim] == n);
6de9cd9a
DN		 3755
3756 /* Evaluate and remember the start of the section. */
3757 start = info->start[dim];
3758 stride = gfc_evaluate_now (stride, &loop.pre);
3759 }
3760
3761 tmp = gfc_conv_array_lbound (desc, n);
10c7a96f 3762 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp);
6de9cd9a 3763
10c7a96f
SB		 3764 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride);
3765 offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp);
6de9cd9a
DN		 3766
3767 if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
3768 {
3769 /* For elemental dimensions, we only need the offset. */
3770 continue;
3771 }
3772
3773 /* Vector subscripts need copying and are handled elsewhere. */
6e45f57b 3774 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6de9cd9a
DN		 3775
3776 /* Set the new lower bound. */
3777 from = loop.from[dim];
3778 to = loop.to[dim];
3779 if (!integer_onep (from))
3780 {
3781 /* Make sure the new section starts at 1. */
10c7a96f
SB		 3782 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3783 gfc_index_one_node, from);
3784 to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
7ab92584 3785 from = gfc_index_one_node;
6de9cd9a
DN		 3786 }
3787 tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
3788 gfc_add_modify_expr (&loop.pre, tmp, from);
3789
3790 /* Set the new upper bound. */
3791 tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
3792 gfc_add_modify_expr (&loop.pre, tmp, to);
3793
3794 /* Multiply the stride by the section stride to get the
3795 total stride. */
10c7a96f
SB		 3796 stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
3797 stride, info->stride[dim]);
6de9cd9a
DN		 3798
3799 if (se->direct_byref)
10c7a96f
SB		 3800 base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
3801 base, stride);
6de9cd9a
DN		 3802
3803 /* Store the new stride. */
3804 tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
3805 gfc_add_modify_expr (&loop.pre, tmp, stride);
3806
3807 dim++;
3808 }
3809
3810 /* Point the data pointer at the first element in the section. */
3811 tmp = gfc_conv_array_data (desc);
3812 tmp = gfc_build_indirect_ref (tmp);
3813 tmp = gfc_build_array_ref (tmp, offset);
3814 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
3815
3816 tmp = gfc_conv_descriptor_data (parm);
7ab92584
SB		 3817 gfc_add_modify_expr (&loop.pre, tmp,
3818 fold_convert (TREE_TYPE (tmp), offset));
6de9cd9a
DN		 3819
3820 if (se->direct_byref)
3821 {
3822 /* Set the offset. */
3823 tmp = gfc_conv_descriptor_offset (parm);
3824 gfc_add_modify_expr (&loop.pre, tmp, base);
3825 }
3826 else
3827 {
3828 /* Only the callee knows what the correct offset it, so just set
3829 it to zero here. */
3830 tmp = gfc_conv_descriptor_offset (parm);
3831 gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
3832 }
3833
3834 if (!se->direct_byref)
3835 {
3836 /* Get a pointer to the new descriptor. */
3837 if (se->want_pointer)
3838 se->expr = gfc_build_addr_expr (NULL, parm);
3839 else
3840 se->expr = parm;
3841 }
3842 }
3843
3844 gfc_add_block_to_block (&se->pre, &loop.pre);
3845 gfc_add_block_to_block (&se->post, &loop.post);
3846
3847 /* Cleanup the scalarizer. */
3848 gfc_cleanup_loop (&loop);
3849}
3850
3851
3852/* Convert an array for passing as an actual parameter. */
3853/* TODO: Optimize passing g77 arrays. */
3854
3855void
3856gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
3857{
3858 tree ptr;
3859 tree desc;
3860 tree tmp;
3861 tree stmt;
3862 gfc_symbol *sym;
3863 stmtblock_t block;
3864
3865 /* Passing address of the array if it is not pointer or assumed-shape. */
3866 if (expr->expr_type == EXPR_VARIABLE
3867 && expr->ref->u.ar.type == AR_FULL && g77)
3868 {
3869 sym = expr->symtree->n.sym;
3870 tmp = gfc_get_symbol_decl (sym);
20c9dc8a
TS		 3871 if (sym->ts.type == BT_CHARACTER)
3872 se->string_length = sym->ts.cl->backend_decl;
6de9cd9a
DN		 3873 if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
3874 && !sym->attr.allocatable)
3875 {
346d5977 3876 /* Some variables are declared directly, others are declared as
841b0c1f
PB		 3877 pointers and allocated on the heap. */
3878 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
3879 se->expr = tmp;
6de9cd9a 3880 else
841b0c1f 3881 se->expr = gfc_build_addr_expr (NULL, tmp);
6de9cd9a
DN		 3882 return;
3883 }
3884 if (sym->attr.allocatable)
3885 {
3886 se->expr = gfc_conv_array_data (tmp);
3887 return;
3888 }
3889 }
3890
3891 se->want_pointer = 1;
3892 gfc_conv_expr_descriptor (se, expr, ss);
3893
3894 if (g77)
3895 {
3896 desc = se->expr;
3897 /* Repack the array. */
3898 tmp = gfc_chainon_list (NULL_TREE, desc);
3899 ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3900 ptr = gfc_evaluate_now (ptr, &se->pre);
3901 se->expr = ptr;
3902
3903 gfc_start_block (&block);
3904
3905 /* Copy the data back. */
3906 tmp = gfc_chainon_list (NULL_TREE, desc);
3907 tmp = gfc_chainon_list (tmp, ptr);
3908 tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
3909 gfc_add_expr_to_block (&block, tmp);
3910
3911 /* Free the temporary. */
3912 tmp = convert (pvoid_type_node, ptr);
3913 tmp = gfc_chainon_list (NULL_TREE, tmp);
3914 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3915 gfc_add_expr_to_block (&block, tmp);
3916
3917 stmt = gfc_finish_block (&block);
3918
3919 gfc_init_block (&block);
3920 /* Only if it was repacked. This code needs to be executed before the
3921 loop cleanup code. */
3922 tmp = gfc_build_indirect_ref (desc);
3923 tmp = gfc_conv_array_data (tmp);
923ab88c
TS		 3924 tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
3925 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
6de9cd9a
DN		 3926
3927 gfc_add_expr_to_block (&block, tmp);
3928 gfc_add_block_to_block (&block, &se->post);
3929
3930 gfc_init_block (&se->post);
3931 gfc_add_block_to_block (&se->post, &block);
3932 }
3933}
3934
3935
3936/* NULLIFY an allocated/pointer array on function entry, free it on exit. */
3937
3938tree
3939gfc_trans_deferred_array (gfc_symbol * sym, tree body)
3940{
3941 tree type;
3942 tree tmp;
3943 tree descriptor;
3944 tree deallocate;
3945 stmtblock_t block;
3946 stmtblock_t fnblock;
3947 locus loc;
3948
3949 /* Make sure the frontend gets these right. */
3950 if (!(sym->attr.pointer || sym->attr.allocatable))
3951 fatal_error
3952 ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
3953
3954 gfc_init_block (&fnblock);
3955
6e45f57b 3956 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
6de9cd9a
DN		 3957 if (sym->ts.type == BT_CHARACTER
3958 && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3959 gfc_trans_init_string_length (sym->ts.cl, &fnblock);
3960
2b58638b
PB		 3961 /* Parameter and use associated variables don't need anything special. */
3962 if (sym->attr.dummy || sym->attr.use_assoc)
6de9cd9a
DN		 3963 {
3964 gfc_add_expr_to_block (&fnblock, body);
3965
3966 return gfc_finish_block (&fnblock);
3967 }
3968
3969 gfc_get_backend_locus (&loc);
3970 gfc_set_backend_locus (&sym->declared_at);
3971 descriptor = sym->backend_decl;
3972
3973 if (TREE_STATIC (descriptor))
3974 {
3975 /* SAVEd variables are not freed on exit. */
3976 gfc_trans_static_array_pointer (sym);
3977 return body;
3978 }
3979
3980 /* Get the descriptor type. */
3981 type = TREE_TYPE (sym->backend_decl);
6e45f57b 3982 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
6de9cd9a
DN		 3983
3984 /* NULLIFY the data pointer. */
3985 tmp = gfc_conv_descriptor_data (descriptor);
7ab92584
SB		 3986 gfc_add_modify_expr (&fnblock, tmp,
3987 convert (TREE_TYPE (tmp), integer_zero_node));
6de9cd9a
DN		 3988
3989 gfc_add_expr_to_block (&fnblock, body);
3990
3991 gfc_set_backend_locus (&loc);
3992 /* Allocatable arrays need to be freed when they go out of scope. */
3993 if (sym->attr.allocatable)
3994 {
3995 gfc_start_block (&block);
3996
3997 /* Deallocate if still allocated at the end of the procedure. */
3998 deallocate = gfc_array_deallocate (descriptor);
3999
4000 tmp = gfc_conv_descriptor_data (descriptor);
923ab88c
TS		 4001 tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_zero_node);
4002 tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
6de9cd9a
DN		 4003 gfc_add_expr_to_block (&block, tmp);
4004
4005 tmp = gfc_finish_block (&block);
4006 gfc_add_expr_to_block (&fnblock, tmp);
4007 }
4008
4009 return gfc_finish_block (&fnblock);
4010}
4011
4012/************ Expression Walking Functions ******************/
4013
4014/* Walk a variable reference.
4015
4016 Possible extension - multiple component subscripts.
4017 x(:,:) = foo%a(:)%b(:)
4018 Transforms to
4019 forall (i=..., j=...)
4020 x(i,j) = foo%a(j)%b(i)
4021 end forall
4022 This adds a fair amout of complexity because you need to deal with more
4023 than one ref. Maybe handle in a similar manner to vector subscripts.
4024 Maybe not worth the effort. */
4025
4026
4027static gfc_ss *
4028gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
4029{
4030 gfc_ref *ref;
4031 gfc_array_ref *ar;
4032 gfc_ss *newss;
4033 gfc_ss *head;
4034 int n;
4035
4036 for (ref = expr->ref; ref; ref = ref->next)
4037 {
4038 /* We're only interested in array sections. */
4039 if (ref->type != REF_ARRAY)
4040 continue;
4041
4042 ar = &ref->u.ar;
4043 switch (ar->type)
4044 {
4045 case AR_ELEMENT:
4046 /* TODO: Take elemental array references out of scalarization
4047 loop. */
4048 break;
4049
4050 case AR_FULL:
4051 newss = gfc_get_ss ();
4052 newss->type = GFC_SS_SECTION;
4053 newss->expr = expr;
4054 newss->next = ss;
4055 newss->data.info.dimen = ar->as->rank;
4056 newss->data.info.ref = ref;
4057
4058 /* Make sure array is the same as array(:,:), this way
4059 we don't need to special case all the time. */
4060 ar->dimen = ar->as->rank;
4061 for (n = 0; n < ar->dimen; n++)
4062 {
4063 newss->data.info.dim[n] = n;
4064 ar->dimen_type[n] = DIMEN_RANGE;
4065
6e45f57b
PB		 4066 gcc_assert (ar->start[n] == NULL);
4067 gcc_assert (ar->end[n] == NULL);
4068 gcc_assert (ar->stride[n] == NULL);
6de9cd9a
DN		 4069 }
4070 return newss;
4071
4072 case AR_SECTION:
4073 newss = gfc_get_ss ();
4074 newss->type = GFC_SS_SECTION;
4075 newss->expr = expr;
4076 newss->next = ss;
4077 newss->data.info.dimen = 0;
4078 newss->data.info.ref = ref;
4079
4080 head = newss;
4081
4082 /* We add SS chains for all the subscripts in the section. */
4083 for (n = 0; n < ar->dimen; n++)
4084 {
4085 gfc_ss *indexss;
4086
4087 switch (ar->dimen_type[n])
4088 {
4089 case DIMEN_ELEMENT:
4090 /* Add SS for elemental (scalar) subscripts. */
6e45f57b 4091 gcc_assert (ar->start[n]);
6de9cd9a
DN		 4092 indexss = gfc_get_ss ();
4093 indexss->type = GFC_SS_SCALAR;
4094 indexss->expr = ar->start[n];
4095 indexss->next = gfc_ss_terminator;
4096 indexss->loop_chain = gfc_ss_terminator;
4097 newss->data.info.subscript[n] = indexss;
4098 break;
4099
4100 case DIMEN_RANGE:
4101 /* We don't add anything for sections, just remember this
4102 dimension for later. */
4103 newss->data.info.dim[newss->data.info.dimen] = n;
4104 newss->data.info.dimen++;
4105 break;
4106
4107 case DIMEN_VECTOR:
4108 /* Get a SS for the vector. This will not be added to the
4109 chain directly. */
4110 indexss = gfc_walk_expr (ar->start[n]);
4111 if (indexss == gfc_ss_terminator)
4112 internal_error ("scalar vector subscript???");
4113
4114 /* We currently only handle really simple vector
4115 subscripts. */
4116 if (indexss->next != gfc_ss_terminator)
4117 gfc_todo_error ("vector subscript expressions");
4118 indexss->loop_chain = gfc_ss_terminator;
4119
4120 /* Mark this as a vector subscript. We don't add this
4121 directly into the chain, but as a subscript of the
4122 existing SS for this term. */
4123 indexss->type = GFC_SS_VECTOR;
4124 newss->data.info.subscript[n] = indexss;
4125 /* Also remember this dimension. */
4126 newss->data.info.dim[newss->data.info.dimen] = n;
4127 newss->data.info.dimen++;
4128 break;
4129
4130 default:
4131 /* We should know what sort of section it is by now. */
6e45f57b 4132 gcc_unreachable ();
6de9cd9a
DN		 4133 }
4134 }
4135 /* We should have at least one non-elemental dimension. */
6e45f57b 4136 gcc_assert (newss->data.info.dimen > 0);
6de9cd9a
DN		 4137 return head;
4138 break;
4139
4140 default:
4141 /* We should know what sort of section it is by now. */
6e45f57b 4142 gcc_unreachable ();
6de9cd9a
DN		 4143 }
4144
4145 }
4146 return ss;
4147}
4148
4149
4150/* Walk an expression operator. If only one operand of a binary expression is
4151 scalar, we must also add the scalar term to the SS chain. */
4152
4153static gfc_ss *
4154gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
4155{
4156 gfc_ss *head;
4157 gfc_ss *head2;
4158 gfc_ss *newss;
4159
58b03ab2
TS		 4160 head = gfc_walk_subexpr (ss, expr->value.op.op1);
4161 if (expr->value.op.op2 == NULL)
6de9cd9a
DN		 4162 head2 = head;
4163 else
58b03ab2 4164 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
6de9cd9a
DN		 4165
4166 /* All operands are scalar. Pass back and let the caller deal with it. */
4167 if (head2 == ss)
4168 return head2;
4169
f7b529fa 4170 /* All operands require scalarization. */
58b03ab2 4171 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
6de9cd9a
DN		 4172 return head2;
4173
4174 /* One of the operands needs scalarization, the other is scalar.
4175 Create a gfc_ss for the scalar expression. */
4176 newss = gfc_get_ss ();
4177 newss->type = GFC_SS_SCALAR;
4178 if (head == ss)
4179 {
4180 /* First operand is scalar. We build the chain in reverse order, so
4181 add the scarar SS after the second operand. */
4182 head = head2;
4183 while (head && head->next != ss)
4184 head = head->next;
4185 /* Check we haven't somehow broken the chain. */
6e45f57b 4186 gcc_assert (head);
6de9cd9a
DN		 4187 newss->next = ss;
4188 head->next = newss;
58b03ab2 4189 newss->expr = expr->value.op.op1;
6de9cd9a
DN		 4190 }
4191 else /* head2 == head */
4192 {
6e45f57b 4193 gcc_assert (head2 == head);
6de9cd9a
DN		 4194 /* Second operand is scalar. */
4195 newss->next = head2;
4196 head2 = newss;
58b03ab2 4197 newss->expr = expr->value.op.op2;
6de9cd9a
DN		 4198 }
4199
4200 return head2;
4201}
4202
4203
4204/* Reverse a SS chain. */
4205
4206static gfc_ss *
4207gfc_reverse_ss (gfc_ss * ss)
4208{
4209 gfc_ss *next;
4210 gfc_ss *head;
4211
6e45f57b 4212 gcc_assert (ss != NULL);
6de9cd9a
DN		 4213
4214 head = gfc_ss_terminator;
4215 while (ss != gfc_ss_terminator)
4216 {
4217 next = ss->next;
6e45f57b
PB		 4218 /* Check we didn't somehow break the chain. */
4219 gcc_assert (next != NULL);
6de9cd9a
DN		 4220 ss->next = head;
4221 head = ss;
4222 ss = next;
4223 }
4224
4225 return (head);
4226}
4227
4228
4229/* Walk the arguments of an elemental function. */
4230
4231gfc_ss *
4232gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
4233 gfc_ss_type type)
4234{
4235 gfc_actual_arglist *arg;
4236 int scalar;
4237 gfc_ss *head;
4238 gfc_ss *tail;
4239 gfc_ss *newss;
4240
4241 head = gfc_ss_terminator;
4242 tail = NULL;
4243 scalar = 1;
4244 for (arg = expr->value.function.actual; arg; arg = arg->next)
4245 {
4246 if (!arg->expr)
4247 continue;
4248
4249 newss = gfc_walk_subexpr (head, arg->expr);
4250 if (newss == head)
4251 {
1f2959f0 4252 /* Scalar argument. */
6de9cd9a
DN		 4253 newss = gfc_get_ss ();
4254 newss->type = type;
4255 newss->expr = arg->expr;
4256 newss->next = head;
4257 }
4258 else
4259 scalar = 0;
4260
4261 head = newss;
4262 if (!tail)
4263 {
4264 tail = head;
4265 while (tail->next != gfc_ss_terminator)
4266 tail = tail->next;
4267 }
4268 }
4269
4270 if (scalar)
4271 {
4272 /* If all the arguments are scalar we don't need the argument SS. */
4273 gfc_free_ss_chain (head);
4274 /* Pass it back. */
4275 return ss;
4276 }
4277
4278 /* Add it onto the existing chain. */
4279 tail->next = ss;
4280 return head;
4281}
4282
4283
4284/* Walk a function call. Scalar functions are passed back, and taken out of
4285 scalarization loops. For elemental functions we walk their arguments.
4286 The result of functions returning arrays is stored in a temporary outside
4287 the loop, so that the function is only called once. Hence we do not need
4288 to walk their arguments. */
4289
4290static gfc_ss *
4291gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
4292{
4293 gfc_ss *newss;
4294 gfc_intrinsic_sym *isym;
4295 gfc_symbol *sym;
4296
4297 isym = expr->value.function.isym;
4298
13413760 4299 /* Handle intrinsic functions separately. */
6de9cd9a
DN		 4300 if (isym)
4301 return gfc_walk_intrinsic_function (ss, expr, isym);
4302
4303 sym = expr->value.function.esym;
4304 if (!sym)
4305 sym = expr->symtree->n.sym;
4306
4307 /* A function that returns arrays. */
4308 if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
4309 {
4310 newss = gfc_get_ss ();
4311 newss->type = GFC_SS_FUNCTION;
4312 newss->expr = expr;
4313 newss->next = ss;
4314 newss->data.info.dimen = expr->rank;
4315 return newss;
4316 }
4317
4318 /* Walk the parameters of an elemental function. For now we always pass
4319 by reference. */
4320 if (sym->attr.elemental)
4321 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
4322
e7dc5b4f 4323 /* Scalar functions are OK as these are evaluated outside the scalarization
6de9cd9a
DN		 4324 loop. Pass back and let the caller deal with it. */
4325 return ss;
4326}
4327
4328
4329/* An array temporary is constructed for array constructors. */
4330
4331static gfc_ss *
4332gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
4333{
4334 gfc_ss *newss;
4335 int n;
4336
4337 newss = gfc_get_ss ();
4338 newss->type = GFC_SS_CONSTRUCTOR;
4339 newss->expr = expr;
4340 newss->next = ss;
4341 newss->data.info.dimen = expr->rank;
4342 for (n = 0; n < expr->rank; n++)
4343 newss->data.info.dim[n] = n;
4344
4345 return newss;
4346}
4347
4348
1f2959f0 4349/* Walk an expression. Add walked expressions to the head of the SS chain.
6de9cd9a
DN		 4350 A wholy scalar expression will not be added. */
4351
4352static gfc_ss *
4353gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
4354{
4355 gfc_ss *head;
4356
4357 switch (expr->expr_type)
4358 {
4359 case EXPR_VARIABLE:
4360 head = gfc_walk_variable_expr (ss, expr);
4361 return head;
4362
4363 case EXPR_OP:
4364 head = gfc_walk_op_expr (ss, expr);
4365 return head;
4366
4367 case EXPR_FUNCTION:
4368 head = gfc_walk_function_expr (ss, expr);
4369 return head;
4370
4371 case EXPR_CONSTANT:
4372 case EXPR_NULL:
4373 case EXPR_STRUCTURE:
4374 /* Pass back and let the caller deal with it. */
4375 break;
4376
4377 case EXPR_ARRAY:
4378 head = gfc_walk_array_constructor (ss, expr);
4379 return head;
4380
4381 case EXPR_SUBSTRING:
4382 /* Pass back and let the caller deal with it. */
4383 break;
4384
4385 default:
4386 internal_error ("bad expression type during walk (%d)",
4387 expr->expr_type);
4388 }
4389 return ss;
4390}
4391
4392
4393/* Entry point for expression walking.
4394 A return value equal to the passed chain means this is
4395 a scalar expression. It is up to the caller to take whatever action is
1f2959f0 4396 necessary to translate these. */
6de9cd9a
DN		 4397
4398gfc_ss *
4399gfc_walk_expr (gfc_expr * expr)
4400{
4401 gfc_ss *res;
4402
4403 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
4404 return gfc_reverse_ss (res);
4405}
4406
Mirror of https://gcc.gnu.org/git/gcc.git