OSDN Git Service

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