OSDN Git Service

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