OSDN Git Service

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