OSDN Git Service

* trans.h (gfc_conv_cray_pointee): Remove.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-array.c
1 /* Array translation routines
2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Paul Brook <paul@nowt.org>
4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
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
63    values are automatically substituted.  Note that gfc_advance_se_ss_chain
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"
83 #include "tree-gimple.h"
84 #include "ggc.h"
85 #include "toplev.h"
86 #include "real.h"
87 #include "flags.h"
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
96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
98
99 /* The contents of this structure aren't actually used, just the address.  */
100 static gfc_ss gfc_ss_terminator_var;
101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
102
103
104 static tree
105 gfc_array_dataptr_type (tree desc)
106 {
107   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
108 }
109
110
111 /* Build expressions to access the members of an array descriptor.
112    It's surprisingly easy to mess up here, so never access
113    an array descriptor by "brute force", always use these
114    functions.  This also avoids problems if we change the format
115    of an array descriptor.
116
117    To understand these magic numbers, look at the comments
118    before gfc_build_array_type() in trans-types.c.
119
120    The code within these defines should be the only code which knows the format
121    of an array descriptor.
122
123    Any code just needing to read obtain the bounds of an array should use
124    gfc_conv_array_* rather than the following functions as these will return
125    know constant values, and work with arrays which do not have descriptors.
126
127    Don't forget to #undef these!  */
128
129 #define DATA_FIELD 0
130 #define OFFSET_FIELD 1
131 #define DTYPE_FIELD 2
132 #define DIMENSION_FIELD 3
133
134 #define STRIDE_SUBFIELD 0
135 #define LBOUND_SUBFIELD 1
136 #define UBOUND_SUBFIELD 2
137
138 /* This provides READ-ONLY access to the data field.  The field itself
139    doesn't have the proper type.  */
140
141 tree
142 gfc_conv_descriptor_data_get (tree desc)
143 {
144   tree field, type, t;
145
146   type = TREE_TYPE (desc);
147   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
148
149   field = TYPE_FIELDS (type);
150   gcc_assert (DATA_FIELD == 0);
151
152   t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
153   t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
154
155   return t;
156 }
157
158 /* This provides WRITE access to the data field.  */
159
160 void
161 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
162 {
163   tree field, type, t;
164
165   type = TREE_TYPE (desc);
166   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
167
168   field = TYPE_FIELDS (type);
169   gcc_assert (DATA_FIELD == 0);
170
171   t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
172   gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
173 }
174
175
176 /* This provides address access to the data field.  This should only be
177    used by array allocation, passing this on to the runtime.  */
178
179 tree
180 gfc_conv_descriptor_data_addr (tree desc)
181 {
182   tree field, type, t;
183
184   type = TREE_TYPE (desc);
185   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
186
187   field = TYPE_FIELDS (type);
188   gcc_assert (DATA_FIELD == 0);
189
190   t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
191   return gfc_build_addr_expr (NULL, t);
192 }
193
194 tree
195 gfc_conv_descriptor_offset (tree desc)
196 {
197   tree type;
198   tree field;
199
200   type = TREE_TYPE (desc);
201   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
202
203   field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
204   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
205
206   return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
207 }
208
209 tree
210 gfc_conv_descriptor_dtype (tree desc)
211 {
212   tree field;
213   tree type;
214
215   type = TREE_TYPE (desc);
216   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
217
218   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
219   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
220
221   return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
222 }
223
224 static tree
225 gfc_conv_descriptor_dimension (tree desc, tree dim)
226 {
227   tree field;
228   tree type;
229   tree tmp;
230
231   type = TREE_TYPE (desc);
232   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
233
234   field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
235   gcc_assert (field != NULL_TREE
236           && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
237           && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
238
239   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
240   tmp = gfc_build_array_ref (tmp, dim);
241   return tmp;
242 }
243
244 tree
245 gfc_conv_descriptor_stride (tree desc, tree dim)
246 {
247   tree tmp;
248   tree field;
249
250   tmp = gfc_conv_descriptor_dimension (desc, dim);
251   field = TYPE_FIELDS (TREE_TYPE (tmp));
252   field = gfc_advance_chain (field, STRIDE_SUBFIELD);
253   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
254
255   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
256   return tmp;
257 }
258
259 tree
260 gfc_conv_descriptor_lbound (tree desc, tree dim)
261 {
262   tree tmp;
263   tree field;
264
265   tmp = gfc_conv_descriptor_dimension (desc, dim);
266   field = TYPE_FIELDS (TREE_TYPE (tmp));
267   field = gfc_advance_chain (field, LBOUND_SUBFIELD);
268   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
269
270   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
271   return tmp;
272 }
273
274 tree
275 gfc_conv_descriptor_ubound (tree desc, tree dim)
276 {
277   tree tmp;
278   tree field;
279
280   tmp = gfc_conv_descriptor_dimension (desc, dim);
281   field = TYPE_FIELDS (TREE_TYPE (tmp));
282   field = gfc_advance_chain (field, UBOUND_SUBFIELD);
283   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
284
285   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
286   return tmp;
287 }
288
289
290 /* Build a null array descriptor constructor.  */
291
292 tree
293 gfc_build_null_descriptor (tree type)
294 {
295   tree field;
296   tree tmp;
297
298   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
299   gcc_assert (DATA_FIELD == 0);
300   field = TYPE_FIELDS (type);
301
302   /* Set a NULL data pointer.  */
303   tmp = build_constructor_single (type, field, null_pointer_node);
304   TREE_CONSTANT (tmp) = 1;
305   TREE_INVARIANT (tmp) = 1;
306   /* All other fields are ignored.  */
307
308   return tmp;
309 }
310
311
312 /* Cleanup those #defines.  */
313
314 #undef DATA_FIELD
315 #undef OFFSET_FIELD
316 #undef DTYPE_FIELD
317 #undef DIMENSION_FIELD
318 #undef STRIDE_SUBFIELD
319 #undef LBOUND_SUBFIELD
320 #undef UBOUND_SUBFIELD
321
322
323 /* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
324    flags & 1 = Main loop body.
325    flags & 2 = temp copy loop.  */
326
327 void
328 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
329 {
330   for (; ss != gfc_ss_terminator; ss = ss->next)
331     ss->useflags = flags;
332 }
333
334 static void gfc_free_ss (gfc_ss *);
335
336
337 /* Free a gfc_ss chain.  */
338
339 static void
340 gfc_free_ss_chain (gfc_ss * ss)
341 {
342   gfc_ss *next;
343
344   while (ss != gfc_ss_terminator)
345     {
346       gcc_assert (ss != NULL);
347       next = ss->next;
348       gfc_free_ss (ss);
349       ss = next;
350     }
351 }
352
353
354 /* Free a SS.  */
355
356 static void
357 gfc_free_ss (gfc_ss * ss)
358 {
359   int n;
360
361   switch (ss->type)
362     {
363     case GFC_SS_SECTION:
364       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
365         {
366           if (ss->data.info.subscript[n])
367             gfc_free_ss_chain (ss->data.info.subscript[n]);
368         }
369       break;
370
371     default:
372       break;
373     }
374
375   gfc_free (ss);
376 }
377
378
379 /* Free all the SS associated with a loop.  */
380
381 void
382 gfc_cleanup_loop (gfc_loopinfo * loop)
383 {
384   gfc_ss *ss;
385   gfc_ss *next;
386
387   ss = loop->ss;
388   while (ss != gfc_ss_terminator)
389     {
390       gcc_assert (ss != NULL);
391       next = ss->loop_chain;
392       gfc_free_ss (ss);
393       ss = next;
394     }
395 }
396
397
398 /* Associate a SS chain with a loop.  */
399
400 void
401 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
402 {
403   gfc_ss *ss;
404
405   if (head == gfc_ss_terminator)
406     return;
407
408   ss = head;
409   for (; ss && ss != gfc_ss_terminator; ss = ss->next)
410     {
411       if (ss->next == gfc_ss_terminator)
412         ss->loop_chain = loop->ss;
413       else
414         ss->loop_chain = ss->next;
415     }
416   gcc_assert (ss == gfc_ss_terminator);
417   loop->ss = head;
418 }
419
420
421 /* Generate an initializer for a static pointer or allocatable array.  */
422
423 void
424 gfc_trans_static_array_pointer (gfc_symbol * sym)
425 {
426   tree type;
427
428   gcc_assert (TREE_STATIC (sym->backend_decl));
429   /* Just zero the data member.  */
430   type = TREE_TYPE (sym->backend_decl);
431   DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
432 }
433
434
435 /* If the bounds of SE's loop have not yet been set, see if they can be
436    determined from array spec AS, which is the array spec of a called
437    function.  MAPPING maps the callee's dummy arguments to the values
438    that the caller is passing.  Add any initialization and finalization
439    code to SE.  */
440
441 void
442 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
443                                      gfc_se * se, gfc_array_spec * as)
444 {
445   int n, dim;
446   gfc_se tmpse;
447   tree lower;
448   tree upper;
449   tree tmp;
450
451   if (as && as->type == AS_EXPLICIT)
452     for (dim = 0; dim < se->loop->dimen; dim++)
453       {
454         n = se->loop->order[dim];
455         if (se->loop->to[n] == NULL_TREE)
456           {
457             /* Evaluate the lower bound.  */
458             gfc_init_se (&tmpse, NULL);
459             gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
460             gfc_add_block_to_block (&se->pre, &tmpse.pre);
461             gfc_add_block_to_block (&se->post, &tmpse.post);
462             lower = tmpse.expr;
463
464             /* ...and the upper bound.  */
465             gfc_init_se (&tmpse, NULL);
466             gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
467             gfc_add_block_to_block (&se->pre, &tmpse.pre);
468             gfc_add_block_to_block (&se->post, &tmpse.post);
469             upper = tmpse.expr;
470
471             /* Set the upper bound of the loop to UPPER - LOWER.  */
472             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
473             tmp = gfc_evaluate_now (tmp, &se->pre);
474             se->loop->to[n] = tmp;
475           }
476       }
477 }
478
479
480 /* Generate code to allocate an array temporary, or create a variable to
481    hold the data.  If size is NULL zero the descriptor so that so that the
482    callee will allocate the array.  Also generates code to free the array
483    afterwards.
484
485    Initialization code is added to PRE and finalization code to POST.
486    DYNAMIC is true if the caller may want to extend the array later
487    using realloc.  This prevents us from putting the array on the stack.  */
488
489 static void
490 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
491                                   gfc_ss_info * info, tree size, tree nelem,
492                                   bool dynamic)
493 {
494   tree tmp;
495   tree args;
496   tree desc;
497   bool onstack;
498
499   desc = info->descriptor;
500   info->offset = gfc_index_zero_node;
501   if (size == NULL_TREE || integer_zerop (size))
502     {
503       /* A callee allocated array.  */
504       gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
505       onstack = FALSE;
506     }
507   else
508     {
509       /* Allocate the temporary.  */
510       onstack = !dynamic && gfc_can_put_var_on_stack (size);
511
512       if (onstack)
513         {
514           /* Make a temporary variable to hold the data.  */
515           tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
516                              integer_one_node);
517           tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
518                                   tmp);
519           tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
520                                   tmp);
521           tmp = gfc_create_var (tmp, "A");
522           tmp = gfc_build_addr_expr (NULL, tmp);
523           gfc_conv_descriptor_data_set (pre, desc, tmp);
524         }
525       else
526         {
527           /* Allocate memory to hold the data.  */
528           args = gfc_chainon_list (NULL_TREE, size);
529
530           if (gfc_index_integer_kind == 4)
531             tmp = gfor_fndecl_internal_malloc;
532           else if (gfc_index_integer_kind == 8)
533             tmp = gfor_fndecl_internal_malloc64;
534           else
535             gcc_unreachable ();
536           tmp = gfc_build_function_call (tmp, args);
537           tmp = gfc_evaluate_now (tmp, pre);
538           gfc_conv_descriptor_data_set (pre, desc, tmp);
539         }
540     }
541   info->data = gfc_conv_descriptor_data_get (desc);
542
543   /* The offset is zero because we create temporaries with a zero
544      lower bound.  */
545   tmp = gfc_conv_descriptor_offset (desc);
546   gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
547
548   if (!onstack)
549     {
550       /* Free the temporary.  */
551       tmp = gfc_conv_descriptor_data_get (desc);
552       tmp = fold_convert (pvoid_type_node, tmp);
553       tmp = gfc_chainon_list (NULL_TREE, tmp);
554       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
555       gfc_add_expr_to_block (post, tmp);
556     }
557 }
558
559
560 /* Generate code to allocate and initialize the descriptor for a temporary
561    array.  This is used for both temporaries needed by the scalarizer, and
562    functions returning arrays.  Adjusts the loop variables to be zero-based,
563    and calculates the loop bounds for callee allocated arrays.
564    Also fills in the descriptor, data and offset fields of info if known.
565    Returns the size of the array, or NULL for a callee allocated array.
566
567    PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage.  */
568
569 tree
570 gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
571                                gfc_loopinfo * loop, gfc_ss_info * info,
572                                tree eltype, bool dynamic)
573 {
574   tree type;
575   tree desc;
576   tree tmp;
577   tree size;
578   tree nelem;
579   int n;
580   int dim;
581
582   gcc_assert (info->dimen > 0);
583   /* Set the lower bound to zero.  */
584   for (dim = 0; dim < info->dimen; dim++)
585     {
586       n = loop->order[dim];
587       if (n < loop->temp_dim)
588         gcc_assert (integer_zerop (loop->from[n]));
589       else
590         {
591           /* Callee allocated arrays may not have a known bound yet.  */
592           if (loop->to[n])
593               loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
594                                          loop->to[n], loop->from[n]);
595           loop->from[n] = gfc_index_zero_node;
596         }
597
598       info->delta[dim] = gfc_index_zero_node;
599       info->start[dim] = gfc_index_zero_node;
600       info->stride[dim] = gfc_index_one_node;
601       info->dim[dim] = dim;
602     }
603
604   /* Initialize the descriptor.  */
605   type =
606     gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
607   desc = gfc_create_var (type, "atmp");
608   GFC_DECL_PACKED_ARRAY (desc) = 1;
609
610   info->descriptor = desc;
611   size = gfc_index_one_node;
612
613   /* Fill in the array dtype.  */
614   tmp = gfc_conv_descriptor_dtype (desc);
615   gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
616
617   /*
618      Fill in the bounds and stride.  This is a packed array, so:
619
620      size = 1;
621      for (n = 0; n < rank; n++)
622        {
623          stride[n] = size
624          delta = ubound[n] + 1 - lbound[n];
625          size = size * delta;
626        }
627      size = size * sizeof(element);
628   */
629
630   for (n = 0; n < info->dimen; n++)
631     {
632       if (loop->to[n] == NULL_TREE)
633         {
634           /* For a callee allocated array express the loop bounds in terms
635              of the descriptor fields.  */
636           tmp = build2 (MINUS_EXPR, gfc_array_index_type,
637                         gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
638                         gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
639           loop->to[n] = tmp;
640           size = NULL_TREE;
641           continue;
642         }
643         
644       /* Store the stride and bound components in the descriptor.  */
645       tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
646       gfc_add_modify_expr (pre, tmp, size);
647
648       tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
649       gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
650
651       tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
652       gfc_add_modify_expr (pre, tmp, loop->to[n]);
653
654       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
655                          loop->to[n], gfc_index_one_node);
656
657       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
658       size = gfc_evaluate_now (size, pre);
659     }
660
661   /* Get the size of the array.  */
662   nelem = size;
663   if (size)
664     size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
665                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
666
667   gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
668
669   if (info->dimen > loop->temp_dim)
670     loop->temp_dim = info->dimen;
671
672   return size;
673 }
674
675
676 /* Return the number of iterations in a loop that starts at START,
677    ends at END, and has step STEP.  */
678
679 static tree
680 gfc_get_iteration_count (tree start, tree end, tree step)
681 {
682   tree tmp;
683   tree type;
684
685   type = TREE_TYPE (step);
686   tmp = fold_build2 (MINUS_EXPR, type, end, start);
687   tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
688   tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
689   tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
690   return fold_convert (gfc_array_index_type, tmp);
691 }
692
693
694 /* Extend the data in array DESC by EXTRA elements.  */
695
696 static void
697 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
698 {
699   tree args;
700   tree tmp;
701   tree size;
702   tree ubound;
703
704   if (integer_zerop (extra))
705     return;
706
707   ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
708
709   /* Add EXTRA to the upper bound.  */
710   tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
711   gfc_add_modify_expr (pblock, ubound, tmp);
712
713   /* Get the value of the current data pointer.  */
714   tmp = gfc_conv_descriptor_data_get (desc);
715   args = gfc_chainon_list (NULL_TREE, tmp);
716
717   /* Calculate the new array size.  */
718   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
719   tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
720   tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
721   args = gfc_chainon_list (args, tmp);
722
723   /* Pick the appropriate realloc function.  */
724   if (gfc_index_integer_kind == 4)
725     tmp = gfor_fndecl_internal_realloc;
726   else if (gfc_index_integer_kind == 8)
727     tmp = gfor_fndecl_internal_realloc64;
728   else
729     gcc_unreachable ();
730
731   /* Set the new data pointer.  */
732   tmp = gfc_build_function_call (tmp, args);
733   gfc_conv_descriptor_data_set (pblock, desc, tmp);
734 }
735
736
737 /* Return true if the bounds of iterator I can only be determined
738    at run time.  */
739
740 static inline bool
741 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
742 {
743   return (i->start->expr_type != EXPR_CONSTANT
744           || i->end->expr_type != EXPR_CONSTANT
745           || i->step->expr_type != EXPR_CONSTANT);
746 }
747
748
749 /* Split the size of constructor element EXPR into the sum of two terms,
750    one of which can be determined at compile time and one of which must
751    be calculated at run time.  Set *SIZE to the former and return true
752    if the latter might be nonzero.  */
753
754 static bool
755 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
756 {
757   if (expr->expr_type == EXPR_ARRAY)
758     return gfc_get_array_constructor_size (size, expr->value.constructor);
759   else if (expr->rank > 0)
760     {
761       /* Calculate everything at run time.  */
762       mpz_set_ui (*size, 0);
763       return true;
764     }
765   else
766     {
767       /* A single element.  */
768       mpz_set_ui (*size, 1);
769       return false;
770     }
771 }
772
773
774 /* Like gfc_get_array_constructor_element_size, but applied to the whole
775    of array constructor C.  */
776
777 static bool
778 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
779 {
780   gfc_iterator *i;
781   mpz_t val;
782   mpz_t len;
783   bool dynamic;
784
785   mpz_set_ui (*size, 0);
786   mpz_init (len);
787   mpz_init (val);
788
789   dynamic = false;
790   for (; c; c = c->next)
791     {
792       i = c->iterator;
793       if (i && gfc_iterator_has_dynamic_bounds (i))
794         dynamic = true;
795       else
796         {
797           dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
798           if (i)
799             {
800               /* Multiply the static part of the element size by the
801                  number of iterations.  */
802               mpz_sub (val, i->end->value.integer, i->start->value.integer);
803               mpz_fdiv_q (val, val, i->step->value.integer);
804               mpz_add_ui (val, val, 1);
805               if (mpz_sgn (val) > 0)
806                 mpz_mul (len, len, val);
807               else
808                 mpz_set_ui (len, 0);
809             }
810           mpz_add (*size, *size, len);
811         }
812     }
813   mpz_clear (len);
814   mpz_clear (val);
815   return dynamic;
816 }
817
818
819 /* Make sure offset is a variable.  */
820
821 static void
822 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
823                          tree * offsetvar)
824 {
825   /* We should have already created the offset variable.  We cannot
826      create it here because we may be in an inner scope.  */
827   gcc_assert (*offsetvar != NULL_TREE);
828   gfc_add_modify_expr (pblock, *offsetvar, *poffset);
829   *poffset = *offsetvar;
830   TREE_USED (*offsetvar) = 1;
831 }
832
833
834 /* Assign an element of an array constructor.  */
835
836 static void
837 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
838                               tree offset, gfc_se * se, gfc_expr * expr)
839 {
840   tree tmp;
841   tree args;
842
843   gfc_conv_expr (se, expr);
844
845   /* Store the value.  */
846   tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
847   tmp = gfc_build_array_ref (tmp, offset);
848   if (expr->ts.type == BT_CHARACTER)
849     {
850       gfc_conv_string_parameter (se);
851       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
852         {
853           /* The temporary is an array of pointers.  */
854           se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
855           gfc_add_modify_expr (&se->pre, tmp, se->expr);
856         }
857       else
858         {
859           /* The temporary is an array of string values.  */
860           tmp = gfc_build_addr_expr (pchar_type_node, tmp);
861           /* We know the temporary and the value will be the same length,
862              so can use memcpy.  */
863           args = gfc_chainon_list (NULL_TREE, tmp);
864           args = gfc_chainon_list (args, se->expr);
865           args = gfc_chainon_list (args, se->string_length);
866           tmp = built_in_decls[BUILT_IN_MEMCPY];
867           tmp = gfc_build_function_call (tmp, args);
868           gfc_add_expr_to_block (&se->pre, tmp);
869         }
870     }
871   else
872     {
873       /* TODO: Should the frontend already have done this conversion?  */
874       se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
875       gfc_add_modify_expr (&se->pre, tmp, se->expr);
876     }
877
878   gfc_add_block_to_block (pblock, &se->pre);
879   gfc_add_block_to_block (pblock, &se->post);
880 }
881
882
883 /* Add the contents of an array to the constructor.  DYNAMIC is as for
884    gfc_trans_array_constructor_value.  */
885
886 static void
887 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
888                                       tree type ATTRIBUTE_UNUSED,
889                                       tree desc, gfc_expr * expr,
890                                       tree * poffset, tree * offsetvar,
891                                       bool dynamic)
892 {
893   gfc_se se;
894   gfc_ss *ss;
895   gfc_loopinfo loop;
896   stmtblock_t body;
897   tree tmp;
898   tree size;
899   int n;
900
901   /* We need this to be a variable so we can increment it.  */
902   gfc_put_offset_into_var (pblock, poffset, offsetvar);
903
904   gfc_init_se (&se, NULL);
905
906   /* Walk the array expression.  */
907   ss = gfc_walk_expr (expr);
908   gcc_assert (ss != gfc_ss_terminator);
909
910   /* Initialize the scalarizer.  */
911   gfc_init_loopinfo (&loop);
912   gfc_add_ss_to_loop (&loop, ss);
913
914   /* Initialize the loop.  */
915   gfc_conv_ss_startstride (&loop);
916   gfc_conv_loop_setup (&loop);
917
918   /* Make sure the constructed array has room for the new data.  */
919   if (dynamic)
920     {
921       /* Set SIZE to the total number of elements in the subarray.  */
922       size = gfc_index_one_node;
923       for (n = 0; n < loop.dimen; n++)
924         {
925           tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
926                                          gfc_index_one_node);
927           size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
928         }
929
930       /* Grow the constructed array by SIZE elements.  */
931       gfc_grow_array (&loop.pre, desc, size);
932     }
933
934   /* Make the loop body.  */
935   gfc_mark_ss_chain_used (ss, 1);
936   gfc_start_scalarized_body (&loop, &body);
937   gfc_copy_loopinfo_to_se (&se, &loop);
938   se.ss = ss;
939
940   if (expr->ts.type == BT_CHARACTER)
941     gfc_todo_error ("character arrays in constructors");
942
943   gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
944   gcc_assert (se.ss == gfc_ss_terminator);
945
946   /* Increment the offset.  */
947   tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
948   gfc_add_modify_expr (&body, *poffset, tmp);
949
950   /* Finish the loop.  */
951   gfc_trans_scalarizing_loops (&loop, &body);
952   gfc_add_block_to_block (&loop.pre, &loop.post);
953   tmp = gfc_finish_block (&loop.pre);
954   gfc_add_expr_to_block (pblock, tmp);
955
956   gfc_cleanup_loop (&loop);
957 }
958
959
960 /* Assign the values to the elements of an array constructor.  DYNAMIC
961    is true if descriptor DESC only contains enough data for the static
962    size calculated by gfc_get_array_constructor_size.  When true, memory
963    for the dynamic parts must be allocated using realloc.  */
964
965 static void
966 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
967                                    tree desc, gfc_constructor * c,
968                                    tree * poffset, tree * offsetvar,
969                                    bool dynamic)
970 {
971   tree tmp;
972   stmtblock_t body;
973   gfc_se se;
974   mpz_t size;
975
976   mpz_init (size);
977   for (; c; c = c->next)
978     {
979       /* If this is an iterator or an array, the offset must be a variable.  */
980       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
981         gfc_put_offset_into_var (pblock, poffset, offsetvar);
982
983       gfc_start_block (&body);
984
985       if (c->expr->expr_type == EXPR_ARRAY)
986         {
987           /* Array constructors can be nested.  */
988           gfc_trans_array_constructor_value (&body, type, desc,
989                                              c->expr->value.constructor,
990                                              poffset, offsetvar, dynamic);
991         }
992       else if (c->expr->rank > 0)
993         {
994           gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
995                                                 poffset, offsetvar, dynamic);
996         }
997       else
998         {
999           /* This code really upsets the gimplifier so don't bother for now.  */
1000           gfc_constructor *p;
1001           HOST_WIDE_INT n;
1002           HOST_WIDE_INT size;
1003
1004           p = c;
1005           n = 0;
1006           while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1007             {
1008               p = p->next;
1009               n++;
1010             }
1011           if (n < 4)
1012             {
1013               /* Scalar values.  */
1014               gfc_init_se (&se, NULL);
1015               gfc_trans_array_ctor_element (&body, desc, *poffset,
1016                                             &se, c->expr);
1017
1018               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1019                                       *poffset, gfc_index_one_node);
1020             }
1021           else
1022             {
1023               /* Collect multiple scalar constants into a constructor.  */
1024               tree list;
1025               tree init;
1026               tree bound;
1027               tree tmptype;
1028
1029               p = c;
1030               list = NULL_TREE;
1031               /* Count the number of consecutive scalar constants.  */
1032               while (p && !(p->iterator
1033                             || p->expr->expr_type != EXPR_CONSTANT))
1034                 {
1035                   gfc_init_se (&se, NULL);
1036                   gfc_conv_constant (&se, p->expr);
1037                   if (p->expr->ts.type == BT_CHARACTER
1038                       && POINTER_TYPE_P (type))
1039                     {
1040                       /* For constant character array constructors we build
1041                          an array of pointers.  */
1042                       se.expr = gfc_build_addr_expr (pchar_type_node,
1043                                                      se.expr);
1044                     }
1045                     
1046                   list = tree_cons (NULL_TREE, se.expr, list);
1047                   c = p;
1048                   p = p->next;
1049                 }
1050
1051               bound = build_int_cst (NULL_TREE, n - 1);
1052               /* Create an array type to hold them.  */
1053               tmptype = build_range_type (gfc_array_index_type,
1054                                           gfc_index_zero_node, bound);
1055               tmptype = build_array_type (type, tmptype);
1056
1057               init = build_constructor_from_list (tmptype, nreverse (list));
1058               TREE_CONSTANT (init) = 1;
1059               TREE_INVARIANT (init) = 1;
1060               TREE_STATIC (init) = 1;
1061               /* Create a static variable to hold the data.  */
1062               tmp = gfc_create_var (tmptype, "data");
1063               TREE_STATIC (tmp) = 1;
1064               TREE_CONSTANT (tmp) = 1;
1065               TREE_INVARIANT (tmp) = 1;
1066               DECL_INITIAL (tmp) = init;
1067               init = tmp;
1068
1069               /* Use BUILTIN_MEMCPY to assign the values.  */
1070               tmp = gfc_conv_descriptor_data_get (desc);
1071               tmp = gfc_build_indirect_ref (tmp);
1072               tmp = gfc_build_array_ref (tmp, *poffset);
1073               tmp = gfc_build_addr_expr (NULL, tmp);
1074               init = gfc_build_addr_expr (NULL, init);
1075
1076               size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1077               bound = build_int_cst (NULL_TREE, n * size);
1078               tmp = gfc_chainon_list (NULL_TREE, tmp);
1079               tmp = gfc_chainon_list (tmp, init);
1080               tmp = gfc_chainon_list (tmp, bound);
1081               tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
1082                                              tmp);
1083               gfc_add_expr_to_block (&body, tmp);
1084
1085               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1086                                       *poffset, build_int_cst (NULL_TREE, n));
1087             }
1088           if (!INTEGER_CST_P (*poffset))
1089             {
1090               gfc_add_modify_expr (&body, *offsetvar, *poffset);
1091               *poffset = *offsetvar;
1092             }
1093         }
1094
1095       /* The frontend should already have done any expansions possible
1096          at compile-time.  */
1097       if (!c->iterator)
1098         {
1099           /* Pass the code as is.  */
1100           tmp = gfc_finish_block (&body);
1101           gfc_add_expr_to_block (pblock, tmp);
1102         }
1103       else
1104         {
1105           /* Build the implied do-loop.  */
1106           tree cond;
1107           tree end;
1108           tree step;
1109           tree loopvar;
1110           tree exit_label;
1111           tree loopbody;
1112           tree tmp2;
1113
1114           loopbody = gfc_finish_block (&body);
1115
1116           gfc_init_se (&se, NULL);
1117           gfc_conv_expr (&se, c->iterator->var);
1118           gfc_add_block_to_block (pblock, &se.pre);
1119           loopvar = se.expr;
1120
1121           /* Initialize the loop.  */
1122           gfc_init_se (&se, NULL);
1123           gfc_conv_expr_val (&se, c->iterator->start);
1124           gfc_add_block_to_block (pblock, &se.pre);
1125           gfc_add_modify_expr (pblock, loopvar, se.expr);
1126
1127           gfc_init_se (&se, NULL);
1128           gfc_conv_expr_val (&se, c->iterator->end);
1129           gfc_add_block_to_block (pblock, &se.pre);
1130           end = gfc_evaluate_now (se.expr, pblock);
1131
1132           gfc_init_se (&se, NULL);
1133           gfc_conv_expr_val (&se, c->iterator->step);
1134           gfc_add_block_to_block (pblock, &se.pre);
1135           step = gfc_evaluate_now (se.expr, pblock);
1136
1137           /* If this array expands dynamically, and the number of iterations
1138              is not constant, we won't have allocated space for the static
1139              part of C->EXPR's size.  Do that now.  */
1140           if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1141             {
1142               /* Get the number of iterations.  */
1143               tmp = gfc_get_iteration_count (loopvar, end, step);
1144
1145               /* Get the static part of C->EXPR's size.  */
1146               gfc_get_array_constructor_element_size (&size, c->expr);
1147               tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1148
1149               /* Grow the array by TMP * TMP2 elements.  */
1150               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1151               gfc_grow_array (pblock, desc, tmp);
1152             }
1153
1154           /* Generate the loop body.  */
1155           exit_label = gfc_build_label_decl (NULL_TREE);
1156           gfc_start_block (&body);
1157
1158           /* Generate the exit condition.  Depending on the sign of
1159              the step variable we have to generate the correct
1160              comparison.  */
1161           tmp = fold_build2 (GT_EXPR, boolean_type_node, step, 
1162                              build_int_cst (TREE_TYPE (step), 0));
1163           cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1164                               build2 (GT_EXPR, boolean_type_node,
1165                                       loopvar, end),
1166                               build2 (LT_EXPR, boolean_type_node,
1167                                       loopvar, end));
1168           tmp = build1_v (GOTO_EXPR, exit_label);
1169           TREE_USED (exit_label) = 1;
1170           tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1171           gfc_add_expr_to_block (&body, tmp);
1172
1173           /* The main loop body.  */
1174           gfc_add_expr_to_block (&body, loopbody);
1175
1176           /* Increase loop variable by step.  */
1177           tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
1178           gfc_add_modify_expr (&body, loopvar, tmp);
1179
1180           /* Finish the loop.  */
1181           tmp = gfc_finish_block (&body);
1182           tmp = build1_v (LOOP_EXPR, tmp);
1183           gfc_add_expr_to_block (pblock, tmp);
1184
1185           /* Add the exit label.  */
1186           tmp = build1_v (LABEL_EXPR, exit_label);
1187           gfc_add_expr_to_block (pblock, tmp);
1188         }
1189     }
1190   mpz_clear (size);
1191 }
1192
1193
1194 /* Figure out the string length of a variable reference expression.
1195    Used by get_array_ctor_strlen.  */
1196
1197 static void
1198 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1199 {
1200   gfc_ref *ref;
1201   gfc_typespec *ts;
1202
1203   /* Don't bother if we already know the length is a constant.  */
1204   if (*len && INTEGER_CST_P (*len))
1205     return;
1206
1207   ts = &expr->symtree->n.sym->ts;
1208   for (ref = expr->ref; ref; ref = ref->next)
1209     {
1210       switch (ref->type)
1211         {
1212         case REF_ARRAY:
1213           /* Array references don't change the string length.  */
1214           break;
1215
1216         case COMPONENT_REF:
1217           /* Use the length of the component.  */
1218           ts = &ref->u.c.component->ts;
1219           break;
1220
1221         default:
1222           /* TODO: Substrings are tricky because we can't evaluate the
1223              expression more than once.  For now we just give up, and hope
1224              we can figure it out elsewhere.  */
1225           return;
1226         }
1227     }
1228
1229   *len = ts->cl->backend_decl;
1230 }
1231
1232
1233 /* Figure out the string length of a character array constructor.
1234    Returns TRUE if all elements are character constants.  */
1235
1236 static bool
1237 get_array_ctor_strlen (gfc_constructor * c, tree * len)
1238 {
1239   bool is_const;
1240   
1241   is_const = TRUE;
1242   for (; c; c = c->next)
1243     {
1244       switch (c->expr->expr_type)
1245         {
1246         case EXPR_CONSTANT:
1247           if (!(*len && INTEGER_CST_P (*len)))
1248             *len = build_int_cstu (gfc_charlen_type_node,
1249                                    c->expr->value.character.length);
1250           break;
1251
1252         case EXPR_ARRAY:
1253           if (!get_array_ctor_strlen (c->expr->value.constructor, len))
1254             is_const = FALSE;
1255           break;
1256
1257         case EXPR_VARIABLE:
1258           is_const = false;
1259           get_array_ctor_var_strlen (c->expr, len);
1260           break;
1261
1262         default:
1263           is_const = FALSE;
1264           /* TODO: For now we just ignore anything we don't know how to
1265              handle, and hope we can figure it out a different way.  */
1266           break;
1267         }
1268     }
1269
1270   return is_const;
1271 }
1272
1273
1274 /* Array constructors are handled by constructing a temporary, then using that
1275    within the scalarization loop.  This is not optimal, but seems by far the
1276    simplest method.  */
1277
1278 static void
1279 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
1280 {
1281   gfc_constructor *c;
1282   tree offset;
1283   tree offsetvar;
1284   tree desc;
1285   tree type;
1286   bool const_string;
1287   bool dynamic;
1288
1289   ss->data.info.dimen = loop->dimen;
1290
1291   c = ss->expr->value.constructor;
1292   if (ss->expr->ts.type == BT_CHARACTER)
1293     {
1294       const_string = get_array_ctor_strlen (c, &ss->string_length);
1295       if (!ss->string_length)
1296         gfc_todo_error ("complex character array constructors");
1297
1298       type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1299       if (const_string)
1300         type = build_pointer_type (type);
1301     }
1302   else
1303     {
1304       const_string = TRUE;
1305       type = gfc_typenode_for_spec (&ss->expr->ts);
1306     }
1307
1308   /* See if the constructor determines the loop bounds.  */
1309   dynamic = false;
1310   if (loop->to[0] == NULL_TREE)
1311     {
1312       mpz_t size;
1313
1314       /* We should have a 1-dimensional, zero-based loop.  */
1315       gcc_assert (loop->dimen == 1);
1316       gcc_assert (integer_zerop (loop->from[0]));
1317
1318       /* Split the constructor size into a static part and a dynamic part.
1319          Allocate the static size up-front and record whether the dynamic
1320          size might be nonzero.  */
1321       mpz_init (size);
1322       dynamic = gfc_get_array_constructor_size (&size, c);
1323       mpz_sub_ui (size, size, 1);
1324       loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1325       mpz_clear (size);
1326     }
1327
1328   gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
1329                                  &ss->data.info, type, dynamic);
1330
1331   desc = ss->data.info.descriptor;
1332   offset = gfc_index_zero_node;
1333   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1334   TREE_USED (offsetvar) = 0;
1335   gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1336                                      &offset, &offsetvar, dynamic);
1337
1338   /* If the array grows dynamically, the upper bound of the loop variable
1339      is determined by the array's final upper bound.  */
1340   if (dynamic)
1341     loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
1342
1343   if (TREE_USED (offsetvar))
1344     pushdecl (offsetvar);
1345   else
1346     gcc_assert (INTEGER_CST_P (offset));
1347 #if 0
1348   /* Disable bound checking for now because it's probably broken.  */
1349   if (flag_bounds_check)
1350     {
1351       gcc_unreachable ();
1352     }
1353 #endif
1354 }
1355
1356
1357 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1358    called after evaluating all of INFO's vector dimensions.  Go through
1359    each such vector dimension and see if we can now fill in any missing
1360    loop bounds.  */
1361
1362 static void
1363 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1364 {
1365   gfc_se se;
1366   tree tmp;
1367   tree desc;
1368   tree zero;
1369   int n;
1370   int dim;
1371
1372   for (n = 0; n < loop->dimen; n++)
1373     {
1374       dim = info->dim[n];
1375       if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1376           && loop->to[n] == NULL)
1377         {
1378           /* Loop variable N indexes vector dimension DIM, and we don't
1379              yet know the upper bound of loop variable N.  Set it to the
1380              difference between the vector's upper and lower bounds.  */
1381           gcc_assert (loop->from[n] == gfc_index_zero_node);
1382           gcc_assert (info->subscript[dim]
1383                       && info->subscript[dim]->type == GFC_SS_VECTOR);
1384
1385           gfc_init_se (&se, NULL);
1386           desc = info->subscript[dim]->data.info.descriptor;
1387           zero = gfc_rank_cst[0];
1388           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1389                              gfc_conv_descriptor_ubound (desc, zero),
1390                              gfc_conv_descriptor_lbound (desc, zero));
1391           tmp = gfc_evaluate_now (tmp, &loop->pre);
1392           loop->to[n] = tmp;
1393         }
1394     }
1395 }
1396
1397
1398 /* Add the pre and post chains for all the scalar expressions in a SS chain
1399    to loop.  This is called after the loop parameters have been calculated,
1400    but before the actual scalarizing loops.  */
1401
1402 static void
1403 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
1404 {
1405   gfc_se se;
1406   int n;
1407
1408   /* TODO: This can generate bad code if there are ordering dependencies.
1409      eg. a callee allocated function and an unknown size constructor.  */
1410   gcc_assert (ss != NULL);
1411
1412   for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
1413     {
1414       gcc_assert (ss);
1415
1416       switch (ss->type)
1417         {
1418         case GFC_SS_SCALAR:
1419           /* Scalar expression.  Evaluate this now.  This includes elemental
1420              dimension indices, but not array section bounds.  */
1421           gfc_init_se (&se, NULL);
1422           gfc_conv_expr (&se, ss->expr);
1423           gfc_add_block_to_block (&loop->pre, &se.pre);
1424
1425           if (ss->expr->ts.type != BT_CHARACTER)
1426             {
1427               /* Move the evaluation of scalar expressions outside the
1428                  scalarization loop.  */
1429               if (subscript)
1430                 se.expr = convert(gfc_array_index_type, se.expr);
1431               se.expr = gfc_evaluate_now (se.expr, &loop->pre);
1432               gfc_add_block_to_block (&loop->pre, &se.post);
1433             }
1434           else
1435             gfc_add_block_to_block (&loop->post, &se.post);
1436
1437           ss->data.scalar.expr = se.expr;
1438           ss->string_length = se.string_length;
1439           break;
1440
1441         case GFC_SS_REFERENCE:
1442           /* Scalar reference.  Evaluate this now.  */
1443           gfc_init_se (&se, NULL);
1444           gfc_conv_expr_reference (&se, ss->expr);
1445           gfc_add_block_to_block (&loop->pre, &se.pre);
1446           gfc_add_block_to_block (&loop->post, &se.post);
1447
1448           ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
1449           ss->string_length = se.string_length;
1450           break;
1451
1452         case GFC_SS_SECTION:
1453           /* Add the expressions for scalar and vector subscripts.  */
1454           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1455             if (ss->data.info.subscript[n])
1456               gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
1457
1458           gfc_set_vector_loop_bounds (loop, &ss->data.info);
1459           break;
1460
1461         case GFC_SS_VECTOR:
1462           /* Get the vector's descriptor and store it in SS.  */
1463           gfc_init_se (&se, NULL);
1464           gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
1465           gfc_add_block_to_block (&loop->pre, &se.pre);
1466           gfc_add_block_to_block (&loop->post, &se.post);
1467           ss->data.info.descriptor = se.expr;
1468           break;
1469
1470         case GFC_SS_INTRINSIC:
1471           gfc_add_intrinsic_ss_code (loop, ss);
1472           break;
1473
1474         case GFC_SS_FUNCTION:
1475           /* Array function return value.  We call the function and save its
1476              result in a temporary for use inside the loop.  */
1477           gfc_init_se (&se, NULL);
1478           se.loop = loop;
1479           se.ss = ss;
1480           gfc_conv_expr (&se, ss->expr);
1481           gfc_add_block_to_block (&loop->pre, &se.pre);
1482           gfc_add_block_to_block (&loop->post, &se.post);
1483           ss->string_length = se.string_length;
1484           break;
1485
1486         case GFC_SS_CONSTRUCTOR:
1487           gfc_trans_array_constructor (loop, ss);
1488           break;
1489
1490         case GFC_SS_TEMP:
1491         case GFC_SS_COMPONENT:
1492           /* Do nothing.  These are handled elsewhere.  */
1493           break;
1494
1495         default:
1496           gcc_unreachable ();
1497         }
1498     }
1499 }
1500
1501
1502 /* Translate expressions for the descriptor and data pointer of a SS.  */
1503 /*GCC ARRAYS*/
1504
1505 static void
1506 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
1507 {
1508   gfc_se se;
1509   tree tmp;
1510
1511   /* Get the descriptor for the array to be scalarized.  */
1512   gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
1513   gfc_init_se (&se, NULL);
1514   se.descriptor_only = 1;
1515   gfc_conv_expr_lhs (&se, ss->expr);
1516   gfc_add_block_to_block (block, &se.pre);
1517   ss->data.info.descriptor = se.expr;
1518   ss->string_length = se.string_length;
1519
1520   if (base)
1521     {
1522       /* Also the data pointer.  */
1523       tmp = gfc_conv_array_data (se.expr);
1524       /* If this is a variable or address of a variable we use it directly.
1525          Otherwise we must evaluate it now to avoid breaking dependency
1526          analysis by pulling the expressions for elemental array indices
1527          inside the loop.  */
1528       if (!(DECL_P (tmp)
1529             || (TREE_CODE (tmp) == ADDR_EXPR
1530                 && DECL_P (TREE_OPERAND (tmp, 0)))))
1531         tmp = gfc_evaluate_now (tmp, block);
1532       ss->data.info.data = tmp;
1533
1534       tmp = gfc_conv_array_offset (se.expr);
1535       ss->data.info.offset = gfc_evaluate_now (tmp, block);
1536     }
1537 }
1538
1539
1540 /* Initialize a gfc_loopinfo structure.  */
1541
1542 void
1543 gfc_init_loopinfo (gfc_loopinfo * loop)
1544 {
1545   int n;
1546
1547   memset (loop, 0, sizeof (gfc_loopinfo));
1548   gfc_init_block (&loop->pre);
1549   gfc_init_block (&loop->post);
1550
1551   /* Initially scalarize in order.  */
1552   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
1553     loop->order[n] = n;
1554
1555   loop->ss = gfc_ss_terminator;
1556 }
1557
1558
1559 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
1560    chain.  */
1561
1562 void
1563 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
1564 {
1565   se->loop = loop;
1566 }
1567
1568
1569 /* Return an expression for the data pointer of an array.  */
1570
1571 tree
1572 gfc_conv_array_data (tree descriptor)
1573 {
1574   tree type;
1575
1576   type = TREE_TYPE (descriptor);
1577   if (GFC_ARRAY_TYPE_P (type))
1578     {
1579       if (TREE_CODE (type) == POINTER_TYPE)
1580         return descriptor;
1581       else
1582         {
1583           /* Descriptorless arrays.  */
1584           return gfc_build_addr_expr (NULL, descriptor);
1585         }
1586     }
1587   else
1588     return gfc_conv_descriptor_data_get (descriptor);
1589 }
1590
1591
1592 /* Return an expression for the base offset of an array.  */
1593
1594 tree
1595 gfc_conv_array_offset (tree descriptor)
1596 {
1597   tree type;
1598
1599   type = TREE_TYPE (descriptor);
1600   if (GFC_ARRAY_TYPE_P (type))
1601     return GFC_TYPE_ARRAY_OFFSET (type);
1602   else
1603     return gfc_conv_descriptor_offset (descriptor);
1604 }
1605
1606
1607 /* Get an expression for the array stride.  */
1608
1609 tree
1610 gfc_conv_array_stride (tree descriptor, int dim)
1611 {
1612   tree tmp;
1613   tree type;
1614
1615   type = TREE_TYPE (descriptor);
1616
1617   /* For descriptorless arrays use the array size.  */
1618   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
1619   if (tmp != NULL_TREE)
1620     return tmp;
1621
1622   tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
1623   return tmp;
1624 }
1625
1626
1627 /* Like gfc_conv_array_stride, but for the lower bound.  */
1628
1629 tree
1630 gfc_conv_array_lbound (tree descriptor, int dim)
1631 {
1632   tree tmp;
1633   tree type;
1634
1635   type = TREE_TYPE (descriptor);
1636
1637   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
1638   if (tmp != NULL_TREE)
1639     return tmp;
1640
1641   tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
1642   return tmp;
1643 }
1644
1645
1646 /* Like gfc_conv_array_stride, but for the upper bound.  */
1647
1648 tree
1649 gfc_conv_array_ubound (tree descriptor, int dim)
1650 {
1651   tree tmp;
1652   tree type;
1653
1654   type = TREE_TYPE (descriptor);
1655
1656   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
1657   if (tmp != NULL_TREE)
1658     return tmp;
1659
1660   /* This should only ever happen when passing an assumed shape array
1661      as an actual parameter.  The value will never be used.  */
1662   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
1663     return gfc_index_zero_node;
1664
1665   tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
1666   return tmp;
1667 }
1668
1669
1670 /* Generate code to perform an array index bound check.  */
1671
1672 static tree
1673 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
1674 {
1675   tree cond;
1676   tree fault;
1677   tree tmp;
1678
1679   if (!flag_bounds_check)
1680     return index;
1681
1682   index = gfc_evaluate_now (index, &se->pre);
1683   /* Check lower bound.  */
1684   tmp = gfc_conv_array_lbound (descriptor, n);
1685   fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
1686   /* Check upper bound.  */
1687   tmp = gfc_conv_array_ubound (descriptor, n);
1688   cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
1689   fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1690
1691   gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1692
1693   return index;
1694 }
1695
1696
1697 /* Return the offset for an index.  Performs bound checking for elemental
1698    dimensions.  Single element references are processed separately.  */
1699
1700 static tree
1701 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
1702                              gfc_array_ref * ar, tree stride)
1703 {
1704   tree index;
1705   tree desc;
1706   tree data;
1707
1708   /* Get the index into the array for this dimension.  */
1709   if (ar)
1710     {
1711       gcc_assert (ar->type != AR_ELEMENT);
1712       switch (ar->dimen_type[dim])
1713         {
1714         case DIMEN_ELEMENT:
1715           gcc_assert (i == -1);
1716           /* Elemental dimension.  */
1717           gcc_assert (info->subscript[dim]
1718                       && info->subscript[dim]->type == GFC_SS_SCALAR);
1719           /* We've already translated this value outside the loop.  */
1720           index = info->subscript[dim]->data.scalar.expr;
1721
1722           index =
1723             gfc_trans_array_bound_check (se, info->descriptor, index, dim);
1724           break;
1725
1726         case DIMEN_VECTOR:
1727           gcc_assert (info && se->loop);
1728           gcc_assert (info->subscript[dim]
1729                       && info->subscript[dim]->type == GFC_SS_VECTOR);
1730           desc = info->subscript[dim]->data.info.descriptor;
1731
1732           /* Get a zero-based index into the vector.  */
1733           index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1734                                se->loop->loopvar[i], se->loop->from[i]);
1735
1736           /* Multiply the index by the stride.  */
1737           index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1738                                index, gfc_conv_array_stride (desc, 0));
1739
1740           /* Read the vector to get an index into info->descriptor.  */
1741           data = gfc_build_indirect_ref (gfc_conv_array_data (desc));
1742           index = gfc_build_array_ref (data, index);
1743           index = gfc_evaluate_now (index, &se->pre);
1744
1745           /* Do any bounds checking on the final info->descriptor index.  */
1746           index = gfc_trans_array_bound_check (se, info->descriptor,
1747                                                index, dim);
1748           break;
1749
1750         case DIMEN_RANGE:
1751           /* Scalarized dimension.  */
1752           gcc_assert (info && se->loop);
1753
1754           /* Multiply the loop variable by the stride and delta.  */
1755           index = se->loop->loopvar[i];
1756           index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
1757                                info->stride[i]);
1758           index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
1759                                info->delta[i]);
1760           break;
1761
1762         default:
1763           gcc_unreachable ();
1764         }
1765     }
1766   else
1767     {
1768       /* Temporary array or derived type component.  */
1769       gcc_assert (se->loop);
1770       index = se->loop->loopvar[se->loop->order[i]];
1771       if (!integer_zerop (info->delta[i]))
1772         index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1773                              index, info->delta[i]);
1774     }
1775
1776   /* Multiply by the stride.  */
1777   index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
1778
1779   return index;
1780 }
1781
1782
1783 /* Build a scalarized reference to an array.  */
1784
1785 static void
1786 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
1787 {
1788   gfc_ss_info *info;
1789   tree index;
1790   tree tmp;
1791   int n;
1792
1793   info = &se->ss->data.info;
1794   if (ar)
1795     n = se->loop->order[0];
1796   else
1797     n = 0;
1798
1799   index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
1800                                        info->stride0);
1801   /* Add the offset for this dimension to the stored offset for all other
1802      dimensions.  */
1803   index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
1804
1805   tmp = gfc_build_indirect_ref (info->data);
1806   se->expr = gfc_build_array_ref (tmp, index);
1807 }
1808
1809
1810 /* Translate access of temporary array.  */
1811
1812 void
1813 gfc_conv_tmp_array_ref (gfc_se * se)
1814 {
1815   se->string_length = se->ss->string_length;
1816   gfc_conv_scalarized_array_ref (se, NULL);
1817 }
1818
1819
1820 /* Build an array reference.  se->expr already holds the array descriptor.
1821    This should be either a variable, indirect variable reference or component
1822    reference.  For arrays which do not have a descriptor, se->expr will be
1823    the data pointer.
1824    a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
1825
1826 void
1827 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
1828 {
1829   int n;
1830   tree index;
1831   tree tmp;
1832   tree stride;
1833   tree fault;
1834   gfc_se indexse;
1835
1836   /* Handle scalarized references separately.  */
1837   if (ar->type != AR_ELEMENT)
1838     {
1839       gfc_conv_scalarized_array_ref (se, ar);
1840       gfc_advance_se_ss_chain (se);
1841       return;
1842     }
1843
1844   index = gfc_index_zero_node;
1845
1846   fault = gfc_index_zero_node;
1847
1848   /* Calculate the offsets from all the dimensions.  */
1849   for (n = 0; n < ar->dimen; n++)
1850     {
1851       /* Calculate the index for this dimension.  */
1852       gfc_init_se (&indexse, se);
1853       gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
1854       gfc_add_block_to_block (&se->pre, &indexse.pre);
1855
1856       if (flag_bounds_check)
1857         {
1858           /* Check array bounds.  */
1859           tree cond;
1860
1861           indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
1862
1863           tmp = gfc_conv_array_lbound (se->expr, n);
1864           cond = fold_build2 (LT_EXPR, boolean_type_node, 
1865                               indexse.expr, tmp);
1866           fault =
1867             fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1868
1869           tmp = gfc_conv_array_ubound (se->expr, n);
1870           cond = fold_build2 (GT_EXPR, boolean_type_node, 
1871                               indexse.expr, tmp);
1872           fault =
1873             fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
1874         }
1875
1876       /* Multiply the index by the stride.  */
1877       stride = gfc_conv_array_stride (se->expr, n);
1878       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
1879                          stride);
1880
1881       /* And add it to the total.  */
1882       index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1883     }
1884
1885   if (flag_bounds_check)
1886     gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
1887
1888   tmp = gfc_conv_array_offset (se->expr);
1889   if (!integer_zerop (tmp))
1890     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
1891       
1892   /* Access the calculated element.  */
1893   tmp = gfc_conv_array_data (se->expr);
1894   tmp = gfc_build_indirect_ref (tmp);
1895   se->expr = gfc_build_array_ref (tmp, index);
1896 }
1897
1898
1899 /* Generate the code to be executed immediately before entering a
1900    scalarization loop.  */
1901
1902 static void
1903 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
1904                          stmtblock_t * pblock)
1905 {
1906   tree index;
1907   tree stride;
1908   gfc_ss_info *info;
1909   gfc_ss *ss;
1910   gfc_se se;
1911   int i;
1912
1913   /* This code will be executed before entering the scalarization loop
1914      for this dimension.  */
1915   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
1916     {
1917       if ((ss->useflags & flag) == 0)
1918         continue;
1919
1920       if (ss->type != GFC_SS_SECTION
1921           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
1922           && ss->type != GFC_SS_COMPONENT)
1923         continue;
1924
1925       info = &ss->data.info;
1926
1927       if (dim >= info->dimen)
1928         continue;
1929
1930       if (dim == info->dimen - 1)
1931         {
1932           /* For the outermost loop calculate the offset due to any
1933              elemental dimensions.  It will have been initialized with the
1934              base offset of the array.  */
1935           if (info->ref)
1936             {
1937               for (i = 0; i < info->ref->u.ar.dimen; i++)
1938                 {
1939                   if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1940                     continue;
1941
1942                   gfc_init_se (&se, NULL);
1943                   se.loop = loop;
1944                   se.expr = info->descriptor;
1945                   stride = gfc_conv_array_stride (info->descriptor, i);
1946                   index = gfc_conv_array_index_offset (&se, info, i, -1,
1947                                                        &info->ref->u.ar,
1948                                                        stride);
1949                   gfc_add_block_to_block (pblock, &se.pre);
1950
1951                   info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1952                                               info->offset, index);
1953                   info->offset = gfc_evaluate_now (info->offset, pblock);
1954                 }
1955
1956               i = loop->order[0];
1957               stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1958             }
1959           else
1960             stride = gfc_conv_array_stride (info->descriptor, 0);
1961
1962           /* Calculate the stride of the innermost loop.  Hopefully this will
1963              allow the backend optimizers to do their stuff more effectively.
1964            */
1965           info->stride0 = gfc_evaluate_now (stride, pblock);
1966         }
1967       else
1968         {
1969           /* Add the offset for the previous loop dimension.  */
1970           gfc_array_ref *ar;
1971
1972           if (info->ref)
1973             {
1974               ar = &info->ref->u.ar;
1975               i = loop->order[dim + 1];
1976             }
1977           else
1978             {
1979               ar = NULL;
1980               i = dim + 1;
1981             }
1982
1983           gfc_init_se (&se, NULL);
1984           se.loop = loop;
1985           se.expr = info->descriptor;
1986           stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
1987           index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
1988                                                ar, stride);
1989           gfc_add_block_to_block (pblock, &se.pre);
1990           info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1991                                       info->offset, index);
1992           info->offset = gfc_evaluate_now (info->offset, pblock);
1993         }
1994
1995       /* Remember this offset for the second loop.  */
1996       if (dim == loop->temp_dim - 1)
1997         info->saved_offset = info->offset;
1998     }
1999 }
2000
2001
2002 /* Start a scalarized expression.  Creates a scope and declares loop
2003    variables.  */
2004
2005 void
2006 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2007 {
2008   int dim;
2009   int n;
2010   int flags;
2011
2012   gcc_assert (!loop->array_parameter);
2013
2014   for (dim = loop->dimen - 1; dim >= 0; dim--)
2015     {
2016       n = loop->order[dim];
2017
2018       gfc_start_block (&loop->code[n]);
2019
2020       /* Create the loop variable.  */
2021       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2022
2023       if (dim < loop->temp_dim)
2024         flags = 3;
2025       else
2026         flags = 1;
2027       /* Calculate values that will be constant within this loop.  */
2028       gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2029     }
2030   gfc_start_block (pbody);
2031 }
2032
2033
2034 /* Generates the actual loop code for a scalarization loop.  */
2035
2036 static void
2037 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2038                                stmtblock_t * pbody)
2039 {
2040   stmtblock_t block;
2041   tree cond;
2042   tree tmp;
2043   tree loopbody;
2044   tree exit_label;
2045
2046   loopbody = gfc_finish_block (pbody);
2047
2048   /* Initialize the loopvar.  */
2049   gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
2050
2051   exit_label = gfc_build_label_decl (NULL_TREE);
2052
2053   /* Generate the loop body.  */
2054   gfc_init_block (&block);
2055
2056   /* The exit condition.  */
2057   cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
2058   tmp = build1_v (GOTO_EXPR, exit_label);
2059   TREE_USED (exit_label) = 1;
2060   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2061   gfc_add_expr_to_block (&block, tmp);
2062
2063   /* The main body.  */
2064   gfc_add_expr_to_block (&block, loopbody);
2065
2066   /* Increment the loopvar.  */
2067   tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2068                 loop->loopvar[n], gfc_index_one_node);
2069   gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
2070
2071   /* Build the loop.  */
2072   tmp = gfc_finish_block (&block);
2073   tmp = build1_v (LOOP_EXPR, tmp);
2074   gfc_add_expr_to_block (&loop->code[n], tmp);
2075
2076   /* Add the exit label.  */
2077   tmp = build1_v (LABEL_EXPR, exit_label);
2078   gfc_add_expr_to_block (&loop->code[n], tmp);
2079 }
2080
2081
2082 /* Finishes and generates the loops for a scalarized expression.  */
2083
2084 void
2085 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2086 {
2087   int dim;
2088   int n;
2089   gfc_ss *ss;
2090   stmtblock_t *pblock;
2091   tree tmp;
2092
2093   pblock = body;
2094   /* Generate the loops.  */
2095   for (dim = 0; dim < loop->dimen; dim++)
2096     {
2097       n = loop->order[dim];
2098       gfc_trans_scalarized_loop_end (loop, n, pblock);
2099       loop->loopvar[n] = NULL_TREE;
2100       pblock = &loop->code[n];
2101     }
2102
2103   tmp = gfc_finish_block (pblock);
2104   gfc_add_expr_to_block (&loop->pre, tmp);
2105
2106   /* Clear all the used flags.  */
2107   for (ss = loop->ss; ss; ss = ss->loop_chain)
2108     ss->useflags = 0;
2109 }
2110
2111
2112 /* Finish the main body of a scalarized expression, and start the secondary
2113    copying body.  */
2114
2115 void
2116 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2117 {
2118   int dim;
2119   int n;
2120   stmtblock_t *pblock;
2121   gfc_ss *ss;
2122
2123   pblock = body;
2124   /* We finish as many loops as are used by the temporary.  */
2125   for (dim = 0; dim < loop->temp_dim - 1; dim++)
2126     {
2127       n = loop->order[dim];
2128       gfc_trans_scalarized_loop_end (loop, n, pblock);
2129       loop->loopvar[n] = NULL_TREE;
2130       pblock = &loop->code[n];
2131     }
2132
2133   /* We don't want to finish the outermost loop entirely.  */
2134   n = loop->order[loop->temp_dim - 1];
2135   gfc_trans_scalarized_loop_end (loop, n, pblock);
2136
2137   /* Restore the initial offsets.  */
2138   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2139     {
2140       if ((ss->useflags & 2) == 0)
2141         continue;
2142
2143       if (ss->type != GFC_SS_SECTION
2144           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2145           && ss->type != GFC_SS_COMPONENT)
2146         continue;
2147
2148       ss->data.info.offset = ss->data.info.saved_offset;
2149     }
2150
2151   /* Restart all the inner loops we just finished.  */
2152   for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2153     {
2154       n = loop->order[dim];
2155
2156       gfc_start_block (&loop->code[n]);
2157
2158       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2159
2160       gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2161     }
2162
2163   /* Start a block for the secondary copying code.  */
2164   gfc_start_block (body);
2165 }
2166
2167
2168 /* Calculate the upper bound of an array section.  */
2169
2170 static tree
2171 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2172 {
2173   int dim;
2174   gfc_expr *end;
2175   tree desc;
2176   tree bound;
2177   gfc_se se;
2178   gfc_ss_info *info;
2179
2180   gcc_assert (ss->type == GFC_SS_SECTION);
2181
2182   info = &ss->data.info;
2183   dim = info->dim[n];
2184
2185   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2186     /* We'll calculate the upper bound once we have access to the
2187        vector's descriptor.  */
2188     return NULL;
2189
2190   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2191   desc = info->descriptor;
2192   end = info->ref->u.ar.end[dim];
2193
2194   if (end)
2195     {
2196       /* The upper bound was specified.  */
2197       gfc_init_se (&se, NULL);
2198       gfc_conv_expr_type (&se, end, gfc_array_index_type);
2199       gfc_add_block_to_block (pblock, &se.pre);
2200       bound = se.expr;
2201     }
2202   else
2203     {
2204       /* No upper bound was specified, so use the bound of the array.  */
2205       bound = gfc_conv_array_ubound (desc, dim);
2206     }
2207
2208   return bound;
2209 }
2210
2211
2212 /* Calculate the lower bound of an array section.  */
2213
2214 static void
2215 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
2216 {
2217   gfc_expr *start;
2218   gfc_expr *stride;
2219   tree desc;
2220   gfc_se se;
2221   gfc_ss_info *info;
2222   int dim;
2223
2224   gcc_assert (ss->type == GFC_SS_SECTION);
2225
2226   info = &ss->data.info;
2227   dim = info->dim[n];
2228
2229   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2230     {
2231       /* We use a zero-based index to access the vector.  */
2232       info->start[n] = gfc_index_zero_node;
2233       info->stride[n] = gfc_index_one_node;
2234       return;
2235     }
2236
2237   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2238   desc = info->descriptor;
2239   start = info->ref->u.ar.start[dim];
2240   stride = info->ref->u.ar.stride[dim];
2241
2242   /* Calculate the start of the range.  For vector subscripts this will
2243      be the range of the vector.  */
2244   if (start)
2245     {
2246       /* Specified section start.  */
2247       gfc_init_se (&se, NULL);
2248       gfc_conv_expr_type (&se, start, gfc_array_index_type);
2249       gfc_add_block_to_block (&loop->pre, &se.pre);
2250       info->start[n] = se.expr;
2251     }
2252   else
2253     {
2254       /* No lower bound specified so use the bound of the array.  */
2255       info->start[n] = gfc_conv_array_lbound (desc, dim);
2256     }
2257   info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
2258
2259   /* Calculate the stride.  */
2260   if (stride == NULL)
2261     info->stride[n] = gfc_index_one_node;
2262   else
2263     {
2264       gfc_init_se (&se, NULL);
2265       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
2266       gfc_add_block_to_block (&loop->pre, &se.pre);
2267       info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
2268     }
2269 }
2270
2271
2272 /* Calculates the range start and stride for a SS chain.  Also gets the
2273    descriptor and data pointer.  The range of vector subscripts is the size
2274    of the vector.  Array bounds are also checked.  */
2275
2276 void
2277 gfc_conv_ss_startstride (gfc_loopinfo * loop)
2278 {
2279   int n;
2280   tree tmp;
2281   gfc_ss *ss;
2282   tree desc;
2283
2284   loop->dimen = 0;
2285   /* Determine the rank of the loop.  */
2286   for (ss = loop->ss;
2287        ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
2288     {
2289       switch (ss->type)
2290         {
2291         case GFC_SS_SECTION:
2292         case GFC_SS_CONSTRUCTOR:
2293         case GFC_SS_FUNCTION:
2294         case GFC_SS_COMPONENT:
2295           loop->dimen = ss->data.info.dimen;
2296           break;
2297
2298         default:
2299           break;
2300         }
2301     }
2302
2303   if (loop->dimen == 0)
2304     gfc_todo_error ("Unable to determine rank of expression");
2305
2306
2307   /* Loop over all the SS in the chain.  */
2308   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2309     {
2310       if (ss->expr && ss->expr->shape && !ss->shape)
2311         ss->shape = ss->expr->shape;
2312
2313       switch (ss->type)
2314         {
2315         case GFC_SS_SECTION:
2316           /* Get the descriptor for the array.  */
2317           gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
2318
2319           for (n = 0; n < ss->data.info.dimen; n++)
2320             gfc_conv_section_startstride (loop, ss, n);
2321           break;
2322
2323         case GFC_SS_CONSTRUCTOR:
2324         case GFC_SS_FUNCTION:
2325           for (n = 0; n < ss->data.info.dimen; n++)
2326             {
2327               ss->data.info.start[n] = gfc_index_zero_node;
2328               ss->data.info.stride[n] = gfc_index_one_node;
2329             }
2330           break;
2331
2332         default:
2333           break;
2334         }
2335     }
2336
2337   /* The rest is just runtime bound checking.  */
2338   if (flag_bounds_check)
2339     {
2340       stmtblock_t block;
2341       tree fault;
2342       tree bound;
2343       tree end;
2344       tree size[GFC_MAX_DIMENSIONS];
2345       gfc_ss_info *info;
2346       int dim;
2347
2348       gfc_start_block (&block);
2349
2350       fault = integer_zero_node;
2351       for (n = 0; n < loop->dimen; n++)
2352         size[n] = NULL_TREE;
2353
2354       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2355         {
2356           if (ss->type != GFC_SS_SECTION)
2357             continue;
2358
2359           /* TODO: range checking for mapped dimensions.  */
2360           info = &ss->data.info;
2361
2362           /* This code only checks ranges.  Elemental and vector
2363              dimensions are checked later.  */
2364           for (n = 0; n < loop->dimen; n++)
2365             {
2366               dim = info->dim[n];
2367               if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
2368                 continue;
2369
2370               desc = ss->data.info.descriptor;
2371
2372               /* Check lower bound.  */
2373               bound = gfc_conv_array_lbound (desc, dim);
2374               tmp = info->start[n];
2375               tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
2376               fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2377                                    tmp);
2378
2379               /* Check the upper bound.  */
2380               bound = gfc_conv_array_ubound (desc, dim);
2381               end = gfc_conv_section_upper_bound (ss, n, &block);
2382               tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
2383               fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
2384                                    tmp);
2385
2386               /* Check the section sizes match.  */
2387               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
2388                                  info->start[n]);
2389               tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
2390                                  info->stride[n]);
2391               /* We remember the size of the first section, and check all the
2392                  others against this.  */
2393               if (size[n])
2394                 {
2395                   tmp =
2396                     fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
2397                   fault =
2398                     build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
2399                 }
2400               else
2401                 size[n] = gfc_evaluate_now (tmp, &block);
2402             }
2403         }
2404       gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
2405
2406       tmp = gfc_finish_block (&block);
2407       gfc_add_expr_to_block (&loop->pre, tmp);
2408     }
2409 }
2410
2411
2412 /* Return true if the two SS could be aliased, i.e. both point to the same data
2413    object.  */
2414 /* TODO: resolve aliases based on frontend expressions.  */
2415
2416 static int
2417 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
2418 {
2419   gfc_ref *lref;
2420   gfc_ref *rref;
2421   gfc_symbol *lsym;
2422   gfc_symbol *rsym;
2423
2424   lsym = lss->expr->symtree->n.sym;
2425   rsym = rss->expr->symtree->n.sym;
2426   if (gfc_symbols_could_alias (lsym, rsym))
2427     return 1;
2428
2429   if (rsym->ts.type != BT_DERIVED
2430       && lsym->ts.type != BT_DERIVED)
2431     return 0;
2432
2433   /* For derived types we must check all the component types.  We can ignore
2434      array references as these will have the same base type as the previous
2435      component ref.  */
2436   for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
2437     {
2438       if (lref->type != REF_COMPONENT)
2439         continue;
2440
2441       if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
2442         return 1;
2443
2444       for (rref = rss->expr->ref; rref != rss->data.info.ref;
2445            rref = rref->next)
2446         {
2447           if (rref->type != REF_COMPONENT)
2448             continue;
2449
2450           if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
2451             return 1;
2452         }
2453     }
2454
2455   for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
2456     {
2457       if (rref->type != REF_COMPONENT)
2458         break;
2459
2460       if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
2461         return 1;
2462     }
2463
2464   return 0;
2465 }
2466
2467
2468 /* Resolve array data dependencies.  Creates a temporary if required.  */
2469 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
2470    dependency.c.  */
2471
2472 void
2473 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
2474                                gfc_ss * rss)
2475 {
2476   gfc_ss *ss;
2477   gfc_ref *lref;
2478   gfc_ref *rref;
2479   gfc_ref *aref;
2480   int nDepend = 0;
2481   int temp_dim = 0;
2482
2483   loop->temp_ss = NULL;
2484   aref = dest->data.info.ref;
2485   temp_dim = 0;
2486
2487   for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
2488     {
2489       if (ss->type != GFC_SS_SECTION)
2490         continue;
2491
2492       if (gfc_could_be_alias (dest, ss))
2493         {
2494           nDepend = 1;
2495           break;
2496         }
2497
2498       if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
2499         {
2500           lref = dest->expr->ref;
2501           rref = ss->expr->ref;
2502
2503           nDepend = gfc_dep_resolver (lref, rref);
2504 #if 0
2505           /* TODO : loop shifting.  */
2506           if (nDepend == 1)
2507             {
2508               /* Mark the dimensions for LOOP SHIFTING */
2509               for (n = 0; n < loop->dimen; n++)
2510                 {
2511                   int dim = dest->data.info.dim[n];
2512
2513                   if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2514                     depends[n] = 2;
2515                   else if (! gfc_is_same_range (&lref->u.ar,
2516                                                 &rref->u.ar, dim, 0))
2517                     depends[n] = 1;
2518                  }
2519
2520               /* Put all the dimensions with dependencies in the
2521                  innermost loops.  */
2522               dim = 0;
2523               for (n = 0; n < loop->dimen; n++)
2524                 {
2525                   gcc_assert (loop->order[n] == n);
2526                   if (depends[n])
2527                   loop->order[dim++] = n;
2528                 }
2529               temp_dim = dim;
2530               for (n = 0; n < loop->dimen; n++)
2531                 {
2532                   if (! depends[n])
2533                   loop->order[dim++] = n;
2534                 }
2535
2536               gcc_assert (dim == loop->dimen);
2537               break;
2538             }
2539 #endif
2540         }
2541     }
2542
2543   if (nDepend == 1)
2544     {
2545       loop->temp_ss = gfc_get_ss ();
2546       loop->temp_ss->type = GFC_SS_TEMP;
2547       loop->temp_ss->data.temp.type =
2548         gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
2549       loop->temp_ss->string_length = dest->string_length;
2550       loop->temp_ss->data.temp.dimen = loop->dimen;
2551       loop->temp_ss->next = gfc_ss_terminator;
2552       gfc_add_ss_to_loop (loop, loop->temp_ss);
2553     }
2554   else
2555     loop->temp_ss = NULL;
2556 }
2557
2558
2559 /* Initialize the scalarization loop.  Creates the loop variables.  Determines
2560    the range of the loop variables.  Creates a temporary if required.
2561    Calculates how to transform from loop variables to array indices for each
2562    expression.  Also generates code for scalar expressions which have been
2563    moved outside the loop.  */
2564
2565 void
2566 gfc_conv_loop_setup (gfc_loopinfo * loop)
2567 {
2568   int n;
2569   int dim;
2570   gfc_ss_info *info;
2571   gfc_ss_info *specinfo;
2572   gfc_ss *ss;
2573   tree tmp;
2574   tree len;
2575   gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
2576   bool dynamic[GFC_MAX_DIMENSIONS];
2577   gfc_constructor *c;
2578   mpz_t *cshape;
2579   mpz_t i;
2580
2581   mpz_init (i);
2582   for (n = 0; n < loop->dimen; n++)
2583     {
2584       loopspec[n] = NULL;
2585       dynamic[n] = false;
2586       /* We use one SS term, and use that to determine the bounds of the
2587          loop for this dimension.  We try to pick the simplest term.  */
2588       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2589         {
2590           if (ss->shape)
2591             {
2592               /* The frontend has worked out the size for us.  */
2593               loopspec[n] = ss;
2594               continue;
2595             }
2596
2597           if (ss->type == GFC_SS_CONSTRUCTOR)
2598             {
2599               /* An unknown size constructor will always be rank one.
2600                  Higher rank constructors will either have known shape,
2601                  or still be wrapped in a call to reshape.  */
2602               gcc_assert (loop->dimen == 1);
2603
2604               /* Always prefer to use the constructor bounds if the size
2605                  can be determined at compile time.  Prefer not to otherwise,
2606                  since the general case involves realloc, and it's better to
2607                  avoid that overhead if possible.  */
2608               c = ss->expr->value.constructor;
2609               dynamic[n] = gfc_get_array_constructor_size (&i, c);
2610               if (!dynamic[n] || !loopspec[n])
2611                 loopspec[n] = ss;
2612               continue;
2613             }
2614
2615           /* TODO: Pick the best bound if we have a choice between a
2616              function and something else.  */
2617           if (ss->type == GFC_SS_FUNCTION)
2618             {
2619               loopspec[n] = ss;
2620               continue;
2621             }
2622
2623           if (ss->type != GFC_SS_SECTION)
2624             continue;
2625
2626           if (loopspec[n])
2627             specinfo = &loopspec[n]->data.info;
2628           else
2629             specinfo = NULL;
2630           info = &ss->data.info;
2631
2632           if (!specinfo)
2633             loopspec[n] = ss;
2634           /* Criteria for choosing a loop specifier (most important first):
2635              doesn't need realloc
2636              stride of one
2637              known stride
2638              known lower bound
2639              known upper bound
2640            */
2641           else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
2642             loopspec[n] = ss;
2643           else if (integer_onep (info->stride[n])
2644                    && !integer_onep (specinfo->stride[n]))
2645             loopspec[n] = ss;
2646           else if (INTEGER_CST_P (info->stride[n])
2647                    && !INTEGER_CST_P (specinfo->stride[n]))
2648             loopspec[n] = ss;
2649           else if (INTEGER_CST_P (info->start[n])
2650                    && !INTEGER_CST_P (specinfo->start[n]))
2651             loopspec[n] = ss;
2652           /* We don't work out the upper bound.
2653              else if (INTEGER_CST_P (info->finish[n])
2654              && ! INTEGER_CST_P (specinfo->finish[n]))
2655              loopspec[n] = ss; */
2656         }
2657
2658       if (!loopspec[n])
2659         gfc_todo_error ("Unable to find scalarization loop specifier");
2660
2661       info = &loopspec[n]->data.info;
2662
2663       /* Set the extents of this range.  */
2664       cshape = loopspec[n]->shape;
2665       if (cshape && INTEGER_CST_P (info->start[n])
2666           && INTEGER_CST_P (info->stride[n]))
2667         {
2668           loop->from[n] = info->start[n];
2669           mpz_set (i, cshape[n]);
2670           mpz_sub_ui (i, i, 1);
2671           /* To = from + (size - 1) * stride.  */
2672           tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
2673           if (!integer_onep (info->stride[n]))
2674             tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2675                                tmp, info->stride[n]);
2676           loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2677                                      loop->from[n], tmp);
2678         }
2679       else
2680         {
2681           loop->from[n] = info->start[n];
2682           switch (loopspec[n]->type)
2683             {
2684             case GFC_SS_CONSTRUCTOR:
2685               /* The upper bound is calculated when we expand the
2686                  constructor.  */
2687               gcc_assert (loop->to[n] == NULL_TREE);
2688               break;
2689
2690             case GFC_SS_SECTION:
2691               loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
2692                                                           &loop->pre);
2693               break;
2694
2695             case GFC_SS_FUNCTION:
2696               /* The loop bound will be set when we generate the call.  */
2697               gcc_assert (loop->to[n] == NULL_TREE);
2698               break;
2699
2700             default:
2701               gcc_unreachable ();
2702             }
2703         }
2704
2705       /* Transform everything so we have a simple incrementing variable.  */
2706       if (integer_onep (info->stride[n]))
2707         info->delta[n] = gfc_index_zero_node;
2708       else
2709         {
2710           /* Set the delta for this section.  */
2711           info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
2712           /* Number of iterations is (end - start + step) / step.
2713              with start = 0, this simplifies to
2714              last = end / step;
2715              for (i = 0; i<=last; i++){...};  */
2716           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2717                              loop->to[n], loop->from[n]);
2718           tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type, 
2719                              tmp, info->stride[n]);
2720           loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
2721           /* Make the loop variable start at 0.  */
2722           loop->from[n] = gfc_index_zero_node;
2723         }
2724     }
2725
2726   /* Add all the scalar code that can be taken out of the loops.
2727      This may include calculating the loop bounds, so do it before
2728      allocating the temporary.  */
2729   gfc_add_loop_ss_code (loop, loop->ss, false);
2730
2731   /* If we want a temporary then create it.  */
2732   if (loop->temp_ss != NULL)
2733     {
2734       gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
2735       tmp = loop->temp_ss->data.temp.type;
2736       len = loop->temp_ss->string_length;
2737       n = loop->temp_ss->data.temp.dimen;
2738       memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
2739       loop->temp_ss->type = GFC_SS_SECTION;
2740       loop->temp_ss->data.info.dimen = n;
2741       gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
2742                                      &loop->temp_ss->data.info, tmp, false);
2743     }
2744
2745   for (n = 0; n < loop->temp_dim; n++)
2746     loopspec[loop->order[n]] = NULL;
2747
2748   mpz_clear (i);
2749
2750   /* For array parameters we don't have loop variables, so don't calculate the
2751      translations.  */
2752   if (loop->array_parameter)
2753     return;
2754
2755   /* Calculate the translation from loop variables to array indices.  */
2756   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2757     {
2758       if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
2759         continue;
2760
2761       info = &ss->data.info;
2762
2763       for (n = 0; n < info->dimen; n++)
2764         {
2765           dim = info->dim[n];
2766
2767           /* If we are specifying the range the delta is already set.  */
2768           if (loopspec[n] != ss)
2769             {
2770               /* Calculate the offset relative to the loop variable.
2771                  First multiply by the stride.  */
2772               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2773                                  loop->from[n], info->stride[n]);
2774
2775               /* Then subtract this from our starting value.  */
2776               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2777                                  info->start[n], tmp);
2778
2779               info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
2780             }
2781         }
2782     }
2783 }
2784
2785
2786 /* Fills in an array descriptor, and returns the size of the array.  The size
2787    will be a simple_val, ie a variable or a constant.  Also calculates the
2788    offset of the base.  Returns the size of the array.
2789    {
2790     stride = 1;
2791     offset = 0;
2792     for (n = 0; n < rank; n++)
2793       {
2794         a.lbound[n] = specified_lower_bound;
2795         offset = offset + a.lbond[n] * stride;
2796         size = 1 - lbound;
2797         a.ubound[n] = specified_upper_bound;
2798         a.stride[n] = stride;
2799         size = ubound + size; //size = ubound + 1 - lbound
2800         stride = stride * size;
2801       }
2802     return (stride);
2803    }  */
2804 /*GCC ARRAYS*/
2805
2806 static tree
2807 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
2808                      gfc_expr ** lower, gfc_expr ** upper,
2809                      stmtblock_t * pblock)
2810 {
2811   tree type;
2812   tree tmp;
2813   tree size;
2814   tree offset;
2815   tree stride;
2816   gfc_expr *ubound;
2817   gfc_se se;
2818   int n;
2819
2820   type = TREE_TYPE (descriptor);
2821
2822   stride = gfc_index_one_node;
2823   offset = gfc_index_zero_node;
2824
2825   /* Set the dtype.  */
2826   tmp = gfc_conv_descriptor_dtype (descriptor);
2827   gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
2828
2829   for (n = 0; n < rank; n++)
2830     {
2831       /* We have 3 possibilities for determining the size of the array:
2832          lower == NULL    => lbound = 1, ubound = upper[n]
2833          upper[n] = NULL  => lbound = 1, ubound = lower[n]
2834          upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
2835       ubound = upper[n];
2836
2837       /* Set lower bound.  */
2838       gfc_init_se (&se, NULL);
2839       if (lower == NULL)
2840         se.expr = gfc_index_one_node;
2841       else
2842         {
2843           gcc_assert (lower[n]);
2844           if (ubound)
2845             {
2846               gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
2847               gfc_add_block_to_block (pblock, &se.pre);
2848             }
2849           else
2850             {
2851               se.expr = gfc_index_one_node;
2852               ubound = lower[n];
2853             }
2854         }
2855       tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
2856       gfc_add_modify_expr (pblock, tmp, se.expr);
2857
2858       /* Work out the offset for this component.  */
2859       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
2860       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
2861
2862       /* Start the calculation for the size of this dimension.  */
2863       size = build2 (MINUS_EXPR, gfc_array_index_type,
2864                      gfc_index_one_node, se.expr);
2865
2866       /* Set upper bound.  */
2867       gfc_init_se (&se, NULL);
2868       gcc_assert (ubound);
2869       gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
2870       gfc_add_block_to_block (pblock, &se.pre);
2871
2872       tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
2873       gfc_add_modify_expr (pblock, tmp, se.expr);
2874
2875       /* Store the stride.  */
2876       tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
2877       gfc_add_modify_expr (pblock, tmp, stride);
2878
2879       /* Calculate the size of this dimension.  */
2880       size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
2881
2882       /* Multiply the stride by the number of elements in this dimension.  */
2883       stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
2884       stride = gfc_evaluate_now (stride, pblock);
2885     }
2886
2887   /* The stride is the number of elements in the array, so multiply by the
2888      size of an element to get the total size.  */
2889   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
2890   size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
2891
2892   if (poffset != NULL)
2893     {
2894       offset = gfc_evaluate_now (offset, pblock);
2895       *poffset = offset;
2896     }
2897
2898   size = gfc_evaluate_now (size, pblock);
2899   return size;
2900 }
2901
2902
2903 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
2904    the work for an ALLOCATE statement.  */
2905 /*GCC ARRAYS*/
2906
2907 void
2908 gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
2909 {
2910   tree tmp;
2911   tree pointer;
2912   tree allocate;
2913   tree offset;
2914   tree size;
2915   gfc_expr **lower;
2916   gfc_expr **upper;
2917
2918   /* Figure out the size of the array.  */
2919   switch (ref->u.ar.type)
2920     {
2921     case AR_ELEMENT:
2922       lower = NULL;
2923       upper = ref->u.ar.start;
2924       break;
2925
2926     case AR_FULL:
2927       gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
2928
2929       lower = ref->u.ar.as->lower;
2930       upper = ref->u.ar.as->upper;
2931       break;
2932
2933     case AR_SECTION:
2934       lower = ref->u.ar.start;
2935       upper = ref->u.ar.end;
2936       break;
2937
2938     default:
2939       gcc_unreachable ();
2940       break;
2941     }
2942
2943   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
2944                               lower, upper, &se->pre);
2945
2946   /* Allocate memory to store the data.  */
2947   tmp = gfc_conv_descriptor_data_addr (se->expr);
2948   pointer = gfc_evaluate_now (tmp, &se->pre);
2949
2950   if (TYPE_PRECISION (gfc_array_index_type) == 32)
2951     allocate = gfor_fndecl_allocate;
2952   else if (TYPE_PRECISION (gfc_array_index_type) == 64)
2953     allocate = gfor_fndecl_allocate64;
2954   else
2955     gcc_unreachable ();
2956
2957   tmp = gfc_chainon_list (NULL_TREE, pointer);
2958   tmp = gfc_chainon_list (tmp, size);
2959   tmp = gfc_chainon_list (tmp, pstat);
2960   tmp = gfc_build_function_call (allocate, tmp);
2961   gfc_add_expr_to_block (&se->pre, tmp);
2962
2963   tmp = gfc_conv_descriptor_offset (se->expr);
2964   gfc_add_modify_expr (&se->pre, tmp, offset);
2965 }
2966
2967
2968 /* Deallocate an array variable.  Also used when an allocated variable goes
2969    out of scope.  */
2970 /*GCC ARRAYS*/
2971
2972 tree
2973 gfc_array_deallocate (tree descriptor, tree pstat)
2974 {
2975   tree var;
2976   tree tmp;
2977   stmtblock_t block;
2978
2979   gfc_start_block (&block);
2980   /* Get a pointer to the data.  */
2981   tmp = gfc_conv_descriptor_data_addr (descriptor);
2982   var = gfc_evaluate_now (tmp, &block);
2983
2984   /* Parameter is the address of the data component.  */
2985   tmp = gfc_chainon_list (NULL_TREE, var);
2986   tmp = gfc_chainon_list (tmp, pstat);
2987   tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
2988   gfc_add_expr_to_block (&block, tmp);
2989
2990   return gfc_finish_block (&block);
2991 }
2992
2993
2994 /* Create an array constructor from an initialization expression.
2995    We assume the frontend already did any expansions and conversions.  */
2996
2997 tree
2998 gfc_conv_array_initializer (tree type, gfc_expr * expr)
2999 {
3000   gfc_constructor *c;
3001   tree tmp;
3002   mpz_t maxval;
3003   gfc_se se;
3004   HOST_WIDE_INT hi;
3005   unsigned HOST_WIDE_INT lo;
3006   tree index, range;
3007   VEC(constructor_elt,gc) *v = NULL;
3008
3009   switch (expr->expr_type)
3010     {
3011     case EXPR_CONSTANT:
3012     case EXPR_STRUCTURE:
3013       /* A single scalar or derived type value.  Create an array with all
3014          elements equal to that value.  */
3015       gfc_init_se (&se, NULL);
3016       
3017       if (expr->expr_type == EXPR_CONSTANT)
3018         gfc_conv_constant (&se, expr);
3019       else
3020         gfc_conv_structure (&se, expr, 1);
3021
3022       tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3023       gcc_assert (tmp && INTEGER_CST_P (tmp));
3024       hi = TREE_INT_CST_HIGH (tmp);
3025       lo = TREE_INT_CST_LOW (tmp);
3026       lo++;
3027       if (lo == 0)
3028         hi++;
3029       /* This will probably eat buckets of memory for large arrays.  */
3030       while (hi != 0 || lo != 0)
3031         {
3032           CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
3033           if (lo == 0)
3034             hi--;
3035           lo--;
3036         }
3037       break;
3038
3039     case EXPR_ARRAY:
3040       /* Create a vector of all the elements.  */
3041       for (c = expr->value.constructor; c; c = c->next)
3042         {
3043           if (c->iterator)
3044             {
3045               /* Problems occur when we get something like
3046                  integer :: a(lots) = (/(i, i=1,lots)/)  */
3047               /* TODO: Unexpanded array initializers.  */
3048               internal_error
3049                 ("Possible frontend bug: array constructor not expanded");
3050             }
3051           if (mpz_cmp_si (c->n.offset, 0) != 0)
3052             index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3053           else
3054             index = NULL_TREE;
3055           mpz_init (maxval);
3056           if (mpz_cmp_si (c->repeat, 0) != 0)
3057             {
3058               tree tmp1, tmp2;
3059
3060               mpz_set (maxval, c->repeat);
3061               mpz_add (maxval, c->n.offset, maxval);
3062               mpz_sub_ui (maxval, maxval, 1);
3063               tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3064               if (mpz_cmp_si (c->n.offset, 0) != 0)
3065                 {
3066                   mpz_add_ui (maxval, c->n.offset, 1);
3067                   tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
3068                 }
3069               else
3070                 tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
3071
3072               range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
3073             }
3074           else
3075             range = NULL;
3076           mpz_clear (maxval);
3077
3078           gfc_init_se (&se, NULL);
3079           switch (c->expr->expr_type)
3080             {
3081             case EXPR_CONSTANT:
3082               gfc_conv_constant (&se, c->expr);
3083               if (range == NULL_TREE)
3084                 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3085               else
3086                 {
3087                   if (index != NULL_TREE)
3088                     CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3089                   CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
3090                 }
3091               break;
3092
3093             case EXPR_STRUCTURE:
3094               gfc_conv_structure (&se, c->expr, 1);
3095               CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
3096               break;
3097
3098             default:
3099               gcc_unreachable ();
3100             }
3101         }
3102       break;
3103
3104     default:
3105       gcc_unreachable ();
3106     }
3107
3108   /* Create a constructor from the list of elements.  */
3109   tmp = build_constructor (type, v);
3110   TREE_CONSTANT (tmp) = 1;
3111   TREE_INVARIANT (tmp) = 1;
3112   return tmp;
3113 }
3114
3115
3116 /* Generate code to evaluate non-constant array bounds.  Sets *poffset and
3117    returns the size (in elements) of the array.  */
3118
3119 static tree
3120 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
3121                         stmtblock_t * pblock)
3122 {
3123   gfc_array_spec *as;
3124   tree size;
3125   tree stride;
3126   tree offset;
3127   tree ubound;
3128   tree lbound;
3129   tree tmp;
3130   gfc_se se;
3131
3132   int dim;
3133
3134   as = sym->as;
3135
3136   size = gfc_index_one_node;
3137   offset = gfc_index_zero_node;
3138   for (dim = 0; dim < as->rank; dim++)
3139     {
3140       /* Evaluate non-constant array bound expressions.  */
3141       lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
3142       if (as->lower[dim] && !INTEGER_CST_P (lbound))
3143         {
3144           gfc_init_se (&se, NULL);
3145           gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
3146           gfc_add_block_to_block (pblock, &se.pre);
3147           gfc_add_modify_expr (pblock, lbound, se.expr);
3148         }
3149       ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
3150       if (as->upper[dim] && !INTEGER_CST_P (ubound))
3151         {
3152           gfc_init_se (&se, NULL);
3153           gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
3154           gfc_add_block_to_block (pblock, &se.pre);
3155           gfc_add_modify_expr (pblock, ubound, se.expr);
3156         }
3157       /* The offset of this dimension.  offset = offset - lbound * stride.  */
3158       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
3159       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3160
3161       /* The size of this dimension, and the stride of the next.  */
3162       if (dim + 1 < as->rank)
3163         stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
3164       else
3165         stride = NULL_TREE;
3166
3167       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
3168         {
3169           /* Calculate stride = size * (ubound + 1 - lbound).  */
3170           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3171                              gfc_index_one_node, lbound);
3172           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
3173           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3174           if (stride)
3175             gfc_add_modify_expr (pblock, stride, tmp);
3176           else
3177             stride = gfc_evaluate_now (tmp, pblock);
3178         }
3179
3180       size = stride;
3181     }
3182
3183   *poffset = offset;
3184   return size;
3185 }
3186
3187
3188 /* Generate code to initialize/allocate an array variable.  */
3189
3190 tree
3191 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
3192 {
3193   stmtblock_t block;
3194   tree type;
3195   tree tmp;
3196   tree fndecl;
3197   tree size;
3198   tree offset;
3199   bool onstack;
3200
3201   gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
3202
3203   /* Do nothing for USEd variables.  */
3204   if (sym->attr.use_assoc)
3205     return fnbody;
3206
3207   type = TREE_TYPE (decl);
3208   gcc_assert (GFC_ARRAY_TYPE_P (type));
3209   onstack = TREE_CODE (type) != POINTER_TYPE;
3210
3211   gfc_start_block (&block);
3212
3213   /* Evaluate character string length.  */
3214   if (sym->ts.type == BT_CHARACTER
3215       && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3216     {
3217       gfc_trans_init_string_length (sym->ts.cl, &block);
3218
3219       /* Emit a DECL_EXPR for this variable, which will cause the
3220          gimplifier to allocate storage, and all that good stuff.  */
3221       tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
3222       gfc_add_expr_to_block (&block, tmp);
3223     }
3224
3225   if (onstack)
3226     {
3227       gfc_add_expr_to_block (&block, fnbody);
3228       return gfc_finish_block (&block);
3229     }
3230
3231   type = TREE_TYPE (type);
3232
3233   gcc_assert (!sym->attr.use_assoc);
3234   gcc_assert (!TREE_STATIC (decl));
3235   gcc_assert (!sym->module);
3236
3237   if (sym->ts.type == BT_CHARACTER
3238       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
3239     gfc_trans_init_string_length (sym->ts.cl, &block);
3240
3241   size = gfc_trans_array_bounds (type, sym, &offset, &block);
3242
3243   /* Don't actually allocate space for Cray Pointees.  */
3244   if (sym->attr.cray_pointee)
3245     {
3246       if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3247         gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3248       gfc_add_expr_to_block (&block, fnbody);
3249       return gfc_finish_block (&block);
3250     }
3251
3252   /* The size is the number of elements in the array, so multiply by the
3253      size of an element to get the total size.  */
3254   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3255   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
3256
3257   /* Allocate memory to hold the data.  */
3258   tmp = gfc_chainon_list (NULL_TREE, size);
3259
3260   if (gfc_index_integer_kind == 4)
3261     fndecl = gfor_fndecl_internal_malloc;
3262   else if (gfc_index_integer_kind == 8)
3263     fndecl = gfor_fndecl_internal_malloc64;
3264   else
3265     gcc_unreachable ();
3266   tmp = gfc_build_function_call (fndecl, tmp);
3267   tmp = fold (convert (TREE_TYPE (decl), tmp));
3268   gfc_add_modify_expr (&block, decl, tmp);
3269
3270   /* Set offset of the array.  */
3271   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3272     gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3273
3274
3275   /* Automatic arrays should not have initializers.  */
3276   gcc_assert (!sym->value);
3277
3278   gfc_add_expr_to_block (&block, fnbody);
3279
3280   /* Free the temporary.  */
3281   tmp = convert (pvoid_type_node, decl);
3282   tmp = gfc_chainon_list (NULL_TREE, tmp);
3283   tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
3284   gfc_add_expr_to_block (&block, tmp);
3285
3286   return gfc_finish_block (&block);
3287 }
3288
3289
3290 /* Generate entry and exit code for g77 calling convention arrays.  */
3291
3292 tree
3293 gfc_trans_g77_array (gfc_symbol * sym, tree body)
3294 {
3295   tree parm;
3296   tree type;
3297   locus loc;
3298   tree offset;
3299   tree tmp;
3300   stmtblock_t block;
3301
3302   gfc_get_backend_locus (&loc);
3303   gfc_set_backend_locus (&sym->declared_at);
3304
3305   /* Descriptor type.  */
3306   parm = sym->backend_decl;
3307   type = TREE_TYPE (parm);
3308   gcc_assert (GFC_ARRAY_TYPE_P (type));
3309
3310   gfc_start_block (&block);
3311
3312   if (sym->ts.type == BT_CHARACTER
3313       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3314     gfc_trans_init_string_length (sym->ts.cl, &block);
3315
3316   /* Evaluate the bounds of the array.  */
3317   gfc_trans_array_bounds (type, sym, &offset, &block);
3318
3319   /* Set the offset.  */
3320   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
3321     gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
3322
3323   /* Set the pointer itself if we aren't using the parameter directly.  */
3324   if (TREE_CODE (parm) != PARM_DECL)
3325     {
3326       tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
3327       gfc_add_modify_expr (&block, parm, tmp);
3328     }
3329   tmp = gfc_finish_block (&block);
3330
3331   gfc_set_backend_locus (&loc);
3332
3333   gfc_start_block (&block);
3334   /* Add the initialization code to the start of the function.  */
3335   gfc_add_expr_to_block (&block, tmp);
3336   gfc_add_expr_to_block (&block, body);
3337
3338   return gfc_finish_block (&block);
3339 }
3340
3341
3342 /* Modify the descriptor of an array parameter so that it has the
3343    correct lower bound.  Also move the upper bound accordingly.
3344    If the array is not packed, it will be copied into a temporary.
3345    For each dimension we set the new lower and upper bounds.  Then we copy the
3346    stride and calculate the offset for this dimension.  We also work out
3347    what the stride of a packed array would be, and see it the two match.
3348    If the array need repacking, we set the stride to the values we just
3349    calculated, recalculate the offset and copy the array data.
3350    Code is also added to copy the data back at the end of the function.
3351    */
3352
3353 tree
3354 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
3355 {
3356   tree size;
3357   tree type;
3358   tree offset;
3359   locus loc;
3360   stmtblock_t block;
3361   stmtblock_t cleanup;
3362   tree lbound;
3363   tree ubound;
3364   tree dubound;
3365   tree dlbound;
3366   tree dumdesc;
3367   tree tmp;
3368   tree stmt;
3369   tree stride;
3370   tree stmt_packed;
3371   tree stmt_unpacked;
3372   tree partial;
3373   gfc_se se;
3374   int n;
3375   int checkparm;
3376   int no_repack;
3377   bool optional_arg;
3378
3379   /* Do nothing for pointer and allocatable arrays.  */
3380   if (sym->attr.pointer || sym->attr.allocatable)
3381     return body;
3382
3383   if (sym->attr.dummy && gfc_is_nodesc_array (sym))
3384     return gfc_trans_g77_array (sym, body);
3385
3386   gfc_get_backend_locus (&loc);
3387   gfc_set_backend_locus (&sym->declared_at);
3388
3389   /* Descriptor type.  */
3390   type = TREE_TYPE (tmpdesc);
3391   gcc_assert (GFC_ARRAY_TYPE_P (type));
3392   dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3393   dumdesc = gfc_build_indirect_ref (dumdesc);
3394   gfc_start_block (&block);
3395
3396   if (sym->ts.type == BT_CHARACTER
3397       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3398     gfc_trans_init_string_length (sym->ts.cl, &block);
3399
3400   checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
3401
3402   no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
3403                 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
3404
3405   if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
3406     {
3407       /* For non-constant shape arrays we only check if the first dimension
3408          is contiguous.  Repacking higher dimensions wouldn't gain us
3409          anything as we still don't know the array stride.  */
3410       partial = gfc_create_var (boolean_type_node, "partial");
3411       TREE_USED (partial) = 1;
3412       tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3413       tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node);
3414       gfc_add_modify_expr (&block, partial, tmp);
3415     }
3416   else
3417     {
3418       partial = NULL_TREE;
3419     }
3420
3421   /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
3422      here, however I think it does the right thing.  */
3423   if (no_repack)
3424     {
3425       /* Set the first stride.  */
3426       stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
3427       stride = gfc_evaluate_now (stride, &block);
3428
3429       tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
3430       tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
3431                     gfc_index_one_node, stride);
3432       stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
3433       gfc_add_modify_expr (&block, stride, tmp);
3434
3435       /* Allow the user to disable array repacking.  */
3436       stmt_unpacked = NULL_TREE;
3437     }
3438   else
3439     {
3440       gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
3441       /* A library call to repack the array if necessary.  */
3442       tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
3443       tmp = gfc_chainon_list (NULL_TREE, tmp);
3444       stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
3445
3446       stride = gfc_index_one_node;
3447     }
3448
3449   /* This is for the case where the array data is used directly without
3450      calling the repack function.  */
3451   if (no_repack || partial != NULL_TREE)
3452     stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
3453   else
3454     stmt_packed = NULL_TREE;
3455
3456   /* Assign the data pointer.  */
3457   if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
3458     {
3459       /* Don't repack unknown shape arrays when the first stride is 1.  */
3460       tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
3461                     stmt_packed, stmt_unpacked);
3462     }
3463   else
3464     tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
3465   gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
3466
3467   offset = gfc_index_zero_node;
3468   size = gfc_index_one_node;
3469
3470   /* Evaluate the bounds of the array.  */
3471   for (n = 0; n < sym->as->rank; n++)
3472     {
3473       if (checkparm || !sym->as->upper[n])
3474         {
3475           /* Get the bounds of the actual parameter.  */
3476           dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
3477           dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
3478         }
3479       else