OSDN Git Service

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