OSDN Git Service

gcc/fortran/:
[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, 0, 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 argument to elemental procedure.  Evaluate this
2058              now.  */
2059           gfc_init_se (&se, NULL);
2060           gfc_conv_expr (&se, ss->expr);
2061           gfc_add_block_to_block (&loop->pre, &se.pre);
2062           gfc_add_block_to_block (&loop->post, &se.post);
2063
2064           ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2065           ss->string_length = se.string_length;
2066           break;
2067
2068         case GFC_SS_SECTION:
2069           /* Add the expressions for scalar and vector subscripts.  */
2070           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2071             if (ss->data.info.subscript[n])
2072               gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2073                                     where);
2074
2075           gfc_set_vector_loop_bounds (loop, &ss->data.info);
2076           break;
2077
2078         case GFC_SS_VECTOR:
2079           /* Get the vector's descriptor and store it in SS.  */
2080           gfc_init_se (&se, NULL);
2081           gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2082           gfc_add_block_to_block (&loop->pre, &se.pre);
2083           gfc_add_block_to_block (&loop->post, &se.post);
2084           ss->data.info.descriptor = se.expr;
2085           break;
2086
2087         case GFC_SS_INTRINSIC:
2088           gfc_add_intrinsic_ss_code (loop, ss);
2089           break;
2090
2091         case GFC_SS_FUNCTION:
2092           /* Array function return value.  We call the function and save its
2093              result in a temporary for use inside the loop.  */
2094           gfc_init_se (&se, NULL);
2095           se.loop = loop;
2096           se.ss = ss;
2097           gfc_conv_expr (&se, ss->expr);
2098           gfc_add_block_to_block (&loop->pre, &se.pre);
2099           gfc_add_block_to_block (&loop->post, &se.post);
2100           ss->string_length = se.string_length;
2101           break;
2102
2103         case GFC_SS_CONSTRUCTOR:
2104           if (ss->expr->ts.type == BT_CHARACTER
2105                 && ss->string_length == NULL
2106                 && ss->expr->ts.u.cl
2107                 && ss->expr->ts.u.cl->length)
2108             {
2109               gfc_init_se (&se, NULL);
2110               gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2111                                   gfc_charlen_type_node);
2112               ss->string_length = se.expr;
2113               gfc_add_block_to_block (&loop->pre, &se.pre);
2114               gfc_add_block_to_block (&loop->post, &se.post);
2115             }
2116           gfc_trans_array_constructor (loop, ss, where);
2117           break;
2118
2119         case GFC_SS_TEMP:
2120         case GFC_SS_COMPONENT:
2121           /* Do nothing.  These are handled elsewhere.  */
2122           break;
2123
2124         default:
2125           gcc_unreachable ();
2126         }
2127     }
2128 }
2129
2130
2131 /* Translate expressions for the descriptor and data pointer of a SS.  */
2132 /*GCC ARRAYS*/
2133
2134 static void
2135 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2136 {
2137   gfc_se se;
2138   tree tmp;
2139
2140   /* Get the descriptor for the array to be scalarized.  */
2141   gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2142   gfc_init_se (&se, NULL);
2143   se.descriptor_only = 1;
2144   gfc_conv_expr_lhs (&se, ss->expr);
2145   gfc_add_block_to_block (block, &se.pre);
2146   ss->data.info.descriptor = se.expr;
2147   ss->string_length = se.string_length;
2148
2149   if (base)
2150     {
2151       /* Also the data pointer.  */
2152       tmp = gfc_conv_array_data (se.expr);
2153       /* If this is a variable or address of a variable we use it directly.
2154          Otherwise we must evaluate it now to avoid breaking dependency
2155          analysis by pulling the expressions for elemental array indices
2156          inside the loop.  */
2157       if (!(DECL_P (tmp)
2158             || (TREE_CODE (tmp) == ADDR_EXPR
2159                 && DECL_P (TREE_OPERAND (tmp, 0)))))
2160         tmp = gfc_evaluate_now (tmp, block);
2161       ss->data.info.data = tmp;
2162
2163       tmp = gfc_conv_array_offset (se.expr);
2164       ss->data.info.offset = gfc_evaluate_now (tmp, block);
2165     }
2166 }
2167
2168
2169 /* Initialize a gfc_loopinfo structure.  */
2170
2171 void
2172 gfc_init_loopinfo (gfc_loopinfo * loop)
2173 {
2174   int n;
2175
2176   memset (loop, 0, sizeof (gfc_loopinfo));
2177   gfc_init_block (&loop->pre);
2178   gfc_init_block (&loop->post);
2179
2180   /* Initially scalarize in order.  */
2181   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2182     loop->order[n] = n;
2183
2184   loop->ss = gfc_ss_terminator;
2185 }
2186
2187
2188 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2189    chain.  */
2190
2191 void
2192 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2193 {
2194   se->loop = loop;
2195 }
2196
2197
2198 /* Return an expression for the data pointer of an array.  */
2199
2200 tree
2201 gfc_conv_array_data (tree descriptor)
2202 {
2203   tree type;
2204
2205   type = TREE_TYPE (descriptor);
2206   if (GFC_ARRAY_TYPE_P (type))
2207     {
2208       if (TREE_CODE (type) == POINTER_TYPE)
2209         return descriptor;
2210       else
2211         {
2212           /* Descriptorless arrays.  */
2213           return gfc_build_addr_expr (NULL_TREE, descriptor);
2214         }
2215     }
2216   else
2217     return gfc_conv_descriptor_data_get (descriptor);
2218 }
2219
2220
2221 /* Return an expression for the base offset of an array.  */
2222
2223 tree
2224 gfc_conv_array_offset (tree descriptor)
2225 {
2226   tree type;
2227
2228   type = TREE_TYPE (descriptor);
2229   if (GFC_ARRAY_TYPE_P (type))
2230     return GFC_TYPE_ARRAY_OFFSET (type);
2231   else
2232     return gfc_conv_descriptor_offset_get (descriptor);
2233 }
2234
2235
2236 /* Get an expression for the array stride.  */
2237
2238 tree
2239 gfc_conv_array_stride (tree descriptor, int dim)
2240 {
2241   tree tmp;
2242   tree type;
2243
2244   type = TREE_TYPE (descriptor);
2245
2246   /* For descriptorless arrays use the array size.  */
2247   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2248   if (tmp != NULL_TREE)
2249     return tmp;
2250
2251   tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2252   return tmp;
2253 }
2254
2255
2256 /* Like gfc_conv_array_stride, but for the lower bound.  */
2257
2258 tree
2259 gfc_conv_array_lbound (tree descriptor, int dim)
2260 {
2261   tree tmp;
2262   tree type;
2263
2264   type = TREE_TYPE (descriptor);
2265
2266   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2267   if (tmp != NULL_TREE)
2268     return tmp;
2269
2270   tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2271   return tmp;
2272 }
2273
2274
2275 /* Like gfc_conv_array_stride, but for the upper bound.  */
2276
2277 tree
2278 gfc_conv_array_ubound (tree descriptor, int dim)
2279 {
2280   tree tmp;
2281   tree type;
2282
2283   type = TREE_TYPE (descriptor);
2284
2285   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2286   if (tmp != NULL_TREE)
2287     return tmp;
2288
2289   /* This should only ever happen when passing an assumed shape array
2290      as an actual parameter.  The value will never be used.  */
2291   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2292     return gfc_index_zero_node;
2293
2294   tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2295   return tmp;
2296 }
2297
2298
2299 /* Generate code to perform an array index bound check.  */
2300
2301 static tree
2302 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2303                              locus * where, bool check_upper)
2304 {
2305   tree fault;
2306   tree tmp_lo, tmp_up;
2307   char *msg;
2308   const char * name = NULL;
2309
2310   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2311     return index;
2312
2313   index = gfc_evaluate_now (index, &se->pre);
2314
2315   /* We find a name for the error message.  */
2316   if (se->ss)
2317     name = se->ss->expr->symtree->name;
2318
2319   if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2320       && se->loop->ss->expr->symtree)
2321     name = se->loop->ss->expr->symtree->name;
2322
2323   if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2324       && se->loop->ss->loop_chain->expr
2325       && se->loop->ss->loop_chain->expr->symtree)
2326     name = se->loop->ss->loop_chain->expr->symtree->name;
2327
2328   if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2329     {
2330       if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2331           && se->loop->ss->expr->value.function.name)
2332         name = se->loop->ss->expr->value.function.name;
2333       else
2334         if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2335             || se->loop->ss->type == GFC_SS_SCALAR)
2336           name = "unnamed constant";
2337     }
2338
2339   if (TREE_CODE (descriptor) == VAR_DECL)
2340     name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2341
2342   /* If upper bound is present, include both bounds in the error message.  */
2343   if (check_upper)
2344     {
2345       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2346       tmp_up = gfc_conv_array_ubound (descriptor, n);
2347
2348       if (name)
2349         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2350                   "outside of expected range (%%ld:%%ld)", n+1, name);
2351       else
2352         asprintf (&msg, "Index '%%ld' of dimension %d "
2353                   "outside of expected range (%%ld:%%ld)", n+1);
2354
2355       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2356       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2357                                fold_convert (long_integer_type_node, index),
2358                                fold_convert (long_integer_type_node, tmp_lo),
2359                                fold_convert (long_integer_type_node, tmp_up));
2360       fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2361       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2362                                fold_convert (long_integer_type_node, index),
2363                                fold_convert (long_integer_type_node, tmp_lo),
2364                                fold_convert (long_integer_type_node, tmp_up));
2365       gfc_free (msg);
2366     }
2367   else
2368     {
2369       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2370
2371       if (name)
2372         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2373                   "below lower bound of %%ld", n+1, name);
2374       else
2375         asprintf (&msg, "Index '%%ld' of dimension %d "
2376                   "below lower bound of %%ld", n+1);
2377
2378       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2379       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2380                                fold_convert (long_integer_type_node, index),
2381                                fold_convert (long_integer_type_node, tmp_lo));
2382       gfc_free (msg);
2383     }
2384
2385   return index;
2386 }
2387
2388
2389 /* Return the offset for an index.  Performs bound checking for elemental
2390    dimensions.  Single element references are processed separately.  */
2391
2392 static tree
2393 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2394                              gfc_array_ref * ar, tree stride)
2395 {
2396   tree index;
2397   tree desc;
2398   tree data;
2399
2400   /* Get the index into the array for this dimension.  */
2401   if (ar)
2402     {
2403       gcc_assert (ar->type != AR_ELEMENT);
2404       switch (ar->dimen_type[dim])
2405         {
2406         case DIMEN_ELEMENT:
2407           /* Elemental dimension.  */
2408           gcc_assert (info->subscript[dim]
2409                       && info->subscript[dim]->type == GFC_SS_SCALAR);
2410           /* We've already translated this value outside the loop.  */
2411           index = info->subscript[dim]->data.scalar.expr;
2412
2413           index = gfc_trans_array_bound_check (se, info->descriptor,
2414                         index, dim, &ar->where,
2415                         ar->as->type != AS_ASSUMED_SIZE
2416                         || dim < ar->dimen - 1);
2417           break;
2418
2419         case DIMEN_VECTOR:
2420           gcc_assert (info && se->loop);
2421           gcc_assert (info->subscript[dim]
2422                       && info->subscript[dim]->type == GFC_SS_VECTOR);
2423           desc = info->subscript[dim]->data.info.descriptor;
2424
2425           /* Get a zero-based index into the vector.  */
2426           index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2427                                se->loop->loopvar[i], se->loop->from[i]);
2428
2429           /* Multiply the index by the stride.  */
2430           index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2431                                index, gfc_conv_array_stride (desc, 0));
2432
2433           /* Read the vector to get an index into info->descriptor.  */
2434           data = build_fold_indirect_ref_loc (input_location,
2435                                           gfc_conv_array_data (desc));
2436           index = gfc_build_array_ref (data, index, NULL);
2437           index = gfc_evaluate_now (index, &se->pre);
2438           index = fold_convert (gfc_array_index_type, index);
2439
2440           /* Do any bounds checking on the final info->descriptor index.  */
2441           index = gfc_trans_array_bound_check (se, info->descriptor,
2442                         index, dim, &ar->where,
2443                         ar->as->type != AS_ASSUMED_SIZE
2444                         || dim < ar->dimen - 1);
2445           break;
2446
2447         case DIMEN_RANGE:
2448           /* Scalarized dimension.  */
2449           gcc_assert (info && se->loop);
2450
2451           /* Multiply the loop variable by the stride and delta.  */
2452           index = se->loop->loopvar[i];
2453           if (!integer_onep (info->stride[i]))
2454             index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2455                                  info->stride[i]);
2456           if (!integer_zerop (info->delta[i]))
2457             index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2458                                  info->delta[i]);
2459           break;
2460
2461         default:
2462           gcc_unreachable ();
2463         }
2464     }
2465   else
2466     {
2467       /* Temporary array or derived type component.  */
2468       gcc_assert (se->loop);
2469       index = se->loop->loopvar[se->loop->order[i]];
2470       if (!integer_zerop (info->delta[i]))
2471         index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2472                              index, info->delta[i]);
2473     }
2474
2475   /* Multiply by the stride.  */
2476   if (!integer_onep (stride))
2477     index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2478
2479   return index;
2480 }
2481
2482
2483 /* Build a scalarized reference to an array.  */
2484
2485 static void
2486 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2487 {
2488   gfc_ss_info *info;
2489   tree decl = NULL_TREE;
2490   tree index;
2491   tree tmp;
2492   int n;
2493
2494   info = &se->ss->data.info;
2495   if (ar)
2496     n = se->loop->order[0];
2497   else
2498     n = 0;
2499
2500   index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2501                                        info->stride0);
2502   /* Add the offset for this dimension to the stored offset for all other
2503      dimensions.  */
2504   if (!integer_zerop (info->offset))
2505     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2506
2507   if (se->ss->expr && is_subref_array (se->ss->expr))
2508     decl = se->ss->expr->symtree->n.sym->backend_decl;
2509
2510   tmp = build_fold_indirect_ref_loc (input_location,
2511                                  info->data);
2512   se->expr = gfc_build_array_ref (tmp, index, decl);
2513 }
2514
2515
2516 /* Translate access of temporary array.  */
2517
2518 void
2519 gfc_conv_tmp_array_ref (gfc_se * se)
2520 {
2521   se->string_length = se->ss->string_length;
2522   gfc_conv_scalarized_array_ref (se, NULL);
2523 }
2524
2525
2526 /* Build an array reference.  se->expr already holds the array descriptor.
2527    This should be either a variable, indirect variable reference or component
2528    reference.  For arrays which do not have a descriptor, se->expr will be
2529    the data pointer.
2530    a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2531
2532 void
2533 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2534                     locus * where)
2535 {
2536   int n;
2537   tree index;
2538   tree tmp;
2539   tree stride;
2540   gfc_se indexse;
2541   gfc_se tmpse;
2542
2543   if (ar->dimen == 0)
2544     return;
2545
2546   /* Handle scalarized references separately.  */
2547   if (ar->type != AR_ELEMENT)
2548     {
2549       gfc_conv_scalarized_array_ref (se, ar);
2550       gfc_advance_se_ss_chain (se);
2551       return;
2552     }
2553
2554   index = gfc_index_zero_node;
2555
2556   /* Calculate the offsets from all the dimensions.  */
2557   for (n = 0; n < ar->dimen; n++)
2558     {
2559       /* Calculate the index for this dimension.  */
2560       gfc_init_se (&indexse, se);
2561       gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2562       gfc_add_block_to_block (&se->pre, &indexse.pre);
2563
2564       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2565         {
2566           /* Check array bounds.  */
2567           tree cond;
2568           char *msg;
2569
2570           /* Evaluate the indexse.expr only once.  */
2571           indexse.expr = save_expr (indexse.expr);
2572
2573           /* Lower bound.  */
2574           tmp = gfc_conv_array_lbound (se->expr, n);
2575           if (sym->attr.temporary)
2576             {
2577               gfc_init_se (&tmpse, se);
2578               gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2579                                   gfc_array_index_type);
2580               gfc_add_block_to_block (&se->pre, &tmpse.pre);
2581               tmp = tmpse.expr;
2582             }
2583
2584           cond = fold_build2 (LT_EXPR, boolean_type_node, 
2585                               indexse.expr, tmp);
2586           asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2587                     "below lower bound of %%ld", n+1, sym->name);
2588           gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2589                                    fold_convert (long_integer_type_node,
2590                                                  indexse.expr),
2591                                    fold_convert (long_integer_type_node, tmp));
2592           gfc_free (msg);
2593
2594           /* Upper bound, but not for the last dimension of assumed-size
2595              arrays.  */
2596           if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
2597             {
2598               tmp = gfc_conv_array_ubound (se->expr, n);
2599               if (sym->attr.temporary)
2600                 {
2601                   gfc_init_se (&tmpse, se);
2602                   gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2603                                       gfc_array_index_type);
2604                   gfc_add_block_to_block (&se->pre, &tmpse.pre);
2605                   tmp = tmpse.expr;
2606                 }
2607
2608               cond = fold_build2 (GT_EXPR, boolean_type_node, 
2609                                   indexse.expr, tmp);
2610               asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2611                         "above upper bound of %%ld", n+1, sym->name);
2612               gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2613                                    fold_convert (long_integer_type_node,
2614                                                  indexse.expr),
2615                                    fold_convert (long_integer_type_node, tmp));
2616               gfc_free (msg);
2617             }
2618         }
2619
2620       /* Multiply the index by the stride.  */
2621       stride = gfc_conv_array_stride (se->expr, n);
2622       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2623                          stride);
2624
2625       /* And add it to the total.  */
2626       index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2627     }
2628
2629   tmp = gfc_conv_array_offset (se->expr);
2630   if (!integer_zerop (tmp))
2631     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2632
2633   /* Access the calculated element.  */
2634   tmp = gfc_conv_array_data (se->expr);
2635   tmp = build_fold_indirect_ref (tmp);
2636   se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2637 }
2638
2639
2640 /* Generate the code to be executed immediately before entering a
2641    scalarization loop.  */
2642
2643 static void
2644 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2645                          stmtblock_t * pblock)
2646 {
2647   tree index;
2648   tree stride;
2649   gfc_ss_info *info;
2650   gfc_ss *ss;
2651   gfc_se se;
2652   int i;
2653
2654   /* This code will be executed before entering the scalarization loop
2655      for this dimension.  */
2656   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2657     {
2658       if ((ss->useflags & flag) == 0)
2659         continue;
2660
2661       if (ss->type != GFC_SS_SECTION
2662           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2663           && ss->type != GFC_SS_COMPONENT)
2664         continue;
2665
2666       info = &ss->data.info;
2667
2668       if (dim >= info->dimen)
2669         continue;
2670
2671       if (dim == info->dimen - 1)
2672         {
2673           /* For the outermost loop calculate the offset due to any
2674              elemental dimensions.  It will have been initialized with the
2675              base offset of the array.  */
2676           if (info->ref)
2677             {
2678               for (i = 0; i < info->ref->u.ar.dimen; i++)
2679                 {
2680                   if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2681                     continue;
2682
2683                   gfc_init_se (&se, NULL);
2684                   se.loop = loop;
2685                   se.expr = info->descriptor;
2686                   stride = gfc_conv_array_stride (info->descriptor, i);
2687                   index = gfc_conv_array_index_offset (&se, info, i, -1,
2688                                                        &info->ref->u.ar,
2689                                                        stride);
2690                   gfc_add_block_to_block (pblock, &se.pre);
2691
2692                   info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2693                                               info->offset, index);
2694                   info->offset = gfc_evaluate_now (info->offset, pblock);
2695                 }
2696
2697               i = loop->order[0];
2698               stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2699             }
2700           else
2701             stride = gfc_conv_array_stride (info->descriptor, 0);
2702
2703           /* Calculate the stride of the innermost loop.  Hopefully this will
2704              allow the backend optimizers to do their stuff more effectively.
2705            */
2706           info->stride0 = gfc_evaluate_now (stride, pblock);
2707         }
2708       else
2709         {
2710           /* Add the offset for the previous loop dimension.  */
2711           gfc_array_ref *ar;
2712
2713           if (info->ref)
2714             {
2715               ar = &info->ref->u.ar;
2716               i = loop->order[dim + 1];
2717             }
2718           else
2719             {
2720               ar = NULL;
2721               i = dim + 1;
2722             }
2723
2724           gfc_init_se (&se, NULL);
2725           se.loop = loop;
2726           se.expr = info->descriptor;
2727           stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2728           index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2729                                                ar, stride);
2730           gfc_add_block_to_block (pblock, &se.pre);
2731           info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2732                                       info->offset, index);
2733           info->offset = gfc_evaluate_now (info->offset, pblock);
2734         }
2735
2736       /* Remember this offset for the second loop.  */
2737       if (dim == loop->temp_dim - 1)
2738         info->saved_offset = info->offset;
2739     }
2740 }
2741
2742
2743 /* Start a scalarized expression.  Creates a scope and declares loop
2744    variables.  */
2745
2746 void
2747 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2748 {
2749   int dim;
2750   int n;
2751   int flags;
2752
2753   gcc_assert (!loop->array_parameter);
2754
2755   for (dim = loop->dimen - 1; dim >= 0; dim--)
2756     {
2757       n = loop->order[dim];
2758
2759       gfc_start_block (&loop->code[n]);
2760
2761       /* Create the loop variable.  */
2762       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2763
2764       if (dim < loop->temp_dim)
2765         flags = 3;
2766       else
2767         flags = 1;
2768       /* Calculate values that will be constant within this loop.  */
2769       gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2770     }
2771   gfc_start_block (pbody);
2772 }
2773
2774
2775 /* Generates the actual loop code for a scalarization loop.  */
2776
2777 void
2778 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2779                                stmtblock_t * pbody)
2780 {
2781   stmtblock_t block;
2782   tree cond;
2783   tree tmp;
2784   tree loopbody;
2785   tree exit_label;
2786   tree stmt;
2787   tree init;
2788   tree incr;
2789
2790   if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2791       == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2792       && n == loop->dimen - 1)
2793     {
2794       /* We create an OMP_FOR construct for the outermost scalarized loop.  */
2795       init = make_tree_vec (1);
2796       cond = make_tree_vec (1);
2797       incr = make_tree_vec (1);
2798
2799       /* Cycle statement is implemented with a goto.  Exit statement must not
2800          be present for this loop.  */
2801       exit_label = gfc_build_label_decl (NULL_TREE);
2802       TREE_USED (exit_label) = 1;
2803
2804       /* Label for cycle statements (if needed).  */
2805       tmp = build1_v (LABEL_EXPR, exit_label);
2806       gfc_add_expr_to_block (pbody, tmp);
2807
2808       stmt = make_node (OMP_FOR);
2809
2810       TREE_TYPE (stmt) = void_type_node;
2811       OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2812
2813       OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2814                                                  OMP_CLAUSE_SCHEDULE);
2815       OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2816         = OMP_CLAUSE_SCHEDULE_STATIC;
2817       if (ompws_flags & OMPWS_NOWAIT)
2818         OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2819           = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2820
2821       /* Initialize the loopvar.  */
2822       TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2823                                          loop->from[n]);
2824       OMP_FOR_INIT (stmt) = init;
2825       /* The exit condition.  */
2826       TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2827                                        loop->loopvar[n], loop->to[n]);
2828       OMP_FOR_COND (stmt) = cond;
2829       /* Increment the loopvar.  */
2830       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2831           loop->loopvar[n], gfc_index_one_node);
2832       TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2833           void_type_node, loop->loopvar[n], tmp);
2834       OMP_FOR_INCR (stmt) = incr;
2835
2836       ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2837       gfc_add_expr_to_block (&loop->code[n], stmt);
2838     }
2839   else
2840     {
2841       loopbody = gfc_finish_block (pbody);
2842
2843       /* Initialize the loopvar.  */
2844       if (loop->loopvar[n] != loop->from[n])
2845         gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2846
2847       exit_label = gfc_build_label_decl (NULL_TREE);
2848
2849       /* Generate the loop body.  */
2850       gfc_init_block (&block);
2851
2852       /* The exit condition.  */
2853       cond = fold_build2 (GT_EXPR, boolean_type_node,
2854                          loop->loopvar[n], loop->to[n]);
2855       tmp = build1_v (GOTO_EXPR, exit_label);
2856       TREE_USED (exit_label) = 1;
2857       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2858       gfc_add_expr_to_block (&block, tmp);
2859
2860       /* The main body.  */
2861       gfc_add_expr_to_block (&block, loopbody);
2862
2863       /* Increment the loopvar.  */
2864       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2865                          loop->loopvar[n], gfc_index_one_node);
2866       gfc_add_modify (&block, loop->loopvar[n], tmp);
2867
2868       /* Build the loop.  */
2869       tmp = gfc_finish_block (&block);
2870       tmp = build1_v (LOOP_EXPR, tmp);
2871       gfc_add_expr_to_block (&loop->code[n], tmp);
2872
2873       /* Add the exit label.  */
2874       tmp = build1_v (LABEL_EXPR, exit_label);
2875       gfc_add_expr_to_block (&loop->code[n], tmp);
2876     }
2877
2878 }
2879
2880
2881 /* Finishes and generates the loops for a scalarized expression.  */
2882
2883 void
2884 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2885 {
2886   int dim;
2887   int n;
2888   gfc_ss *ss;
2889   stmtblock_t *pblock;
2890   tree tmp;
2891
2892   pblock = body;
2893   /* Generate the loops.  */
2894   for (dim = 0; dim < loop->dimen; dim++)
2895     {
2896       n = loop->order[dim];
2897       gfc_trans_scalarized_loop_end (loop, n, pblock);
2898       loop->loopvar[n] = NULL_TREE;
2899       pblock = &loop->code[n];
2900     }
2901
2902   tmp = gfc_finish_block (pblock);
2903   gfc_add_expr_to_block (&loop->pre, tmp);
2904
2905   /* Clear all the used flags.  */
2906   for (ss = loop->ss; ss; ss = ss->loop_chain)
2907     ss->useflags = 0;
2908 }
2909
2910
2911 /* Finish the main body of a scalarized expression, and start the secondary
2912    copying body.  */
2913
2914 void
2915 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2916 {
2917   int dim;
2918   int n;
2919   stmtblock_t *pblock;
2920   gfc_ss *ss;
2921
2922   pblock = body;
2923   /* We finish as many loops as are used by the temporary.  */
2924   for (dim = 0; dim < loop->temp_dim - 1; dim++)
2925     {
2926       n = loop->order[dim];
2927       gfc_trans_scalarized_loop_end (loop, n, pblock);
2928       loop->loopvar[n] = NULL_TREE;
2929       pblock = &loop->code[n];
2930     }
2931
2932   /* We don't want to finish the outermost loop entirely.  */
2933   n = loop->order[loop->temp_dim - 1];
2934   gfc_trans_scalarized_loop_end (loop, n, pblock);
2935
2936   /* Restore the initial offsets.  */
2937   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2938     {
2939       if ((ss->useflags & 2) == 0)
2940         continue;
2941
2942       if (ss->type != GFC_SS_SECTION
2943           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2944           && ss->type != GFC_SS_COMPONENT)
2945         continue;
2946
2947       ss->data.info.offset = ss->data.info.saved_offset;
2948     }
2949
2950   /* Restart all the inner loops we just finished.  */
2951   for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2952     {
2953       n = loop->order[dim];
2954
2955       gfc_start_block (&loop->code[n]);
2956
2957       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2958
2959       gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2960     }
2961
2962   /* Start a block for the secondary copying code.  */
2963   gfc_start_block (body);
2964 }
2965
2966
2967 /* Calculate the upper bound of an array section.  */
2968
2969 static tree
2970 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2971 {
2972   int dim;
2973   gfc_expr *end;
2974   tree desc;
2975   tree bound;
2976   gfc_se se;
2977   gfc_ss_info *info;
2978
2979   gcc_assert (ss->type == GFC_SS_SECTION);
2980
2981   info = &ss->data.info;
2982   dim = info->dim[n];
2983
2984   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2985     /* We'll calculate the upper bound once we have access to the
2986        vector's descriptor.  */
2987     return NULL;
2988
2989   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2990   desc = info->descriptor;
2991   end = info->ref->u.ar.end[dim];
2992
2993   if (end)
2994     {
2995       /* The upper bound was specified.  */
2996       gfc_init_se (&se, NULL);
2997       gfc_conv_expr_type (&se, end, gfc_array_index_type);
2998       gfc_add_block_to_block (pblock, &se.pre);
2999       bound = se.expr;
3000     }
3001   else
3002     {
3003       /* No upper bound was specified, so use the bound of the array.  */
3004       bound = gfc_conv_array_ubound (desc, dim);
3005     }
3006
3007   return bound;
3008 }
3009
3010
3011 /* Calculate the lower bound of an array section.  */
3012
3013 static void
3014 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3015 {
3016   gfc_expr *start;
3017   gfc_expr *end;
3018   gfc_expr *stride;
3019   tree desc;
3020   gfc_se se;
3021   gfc_ss_info *info;
3022   int dim;
3023
3024   gcc_assert (ss->type == GFC_SS_SECTION);
3025
3026   info = &ss->data.info;
3027   dim = info->dim[n];
3028
3029   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3030     {
3031       /* We use a zero-based index to access the vector.  */
3032       info->start[n] = gfc_index_zero_node;
3033       info->end[n] = gfc_index_zero_node;
3034       info->stride[n] = gfc_index_one_node;
3035       return;
3036     }
3037
3038   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3039   desc = info->descriptor;
3040   start = info->ref->u.ar.start[dim];
3041   end = info->ref->u.ar.end[dim];
3042   stride = info->ref->u.ar.stride[dim];
3043
3044   /* Calculate the start of the range.  For vector subscripts this will
3045      be the range of the vector.  */
3046   if (start)
3047     {
3048       /* Specified section start.  */
3049       gfc_init_se (&se, NULL);
3050       gfc_conv_expr_type (&se, start, gfc_array_index_type);
3051       gfc_add_block_to_block (&loop->pre, &se.pre);
3052       info->start[n] = se.expr;
3053     }
3054   else
3055     {
3056       /* No lower bound specified so use the bound of the array.  */
3057       info->start[n] = gfc_conv_array_lbound (desc, dim);
3058     }
3059   info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3060
3061   /* Similarly calculate the end.  Although this is not used in the
3062      scalarizer, it is needed when checking bounds and where the end
3063      is an expression with side-effects.  */
3064   if (end)
3065     {
3066       /* Specified section start.  */
3067       gfc_init_se (&se, NULL);
3068       gfc_conv_expr_type (&se, end, gfc_array_index_type);
3069       gfc_add_block_to_block (&loop->pre, &se.pre);
3070       info->end[n] = se.expr;
3071     }
3072   else
3073     {
3074       /* No upper bound specified so use the bound of the array.  */
3075       info->end[n] = gfc_conv_array_ubound (desc, dim);
3076     }
3077   info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3078
3079   /* Calculate the stride.  */
3080   if (stride == NULL)
3081     info->stride[n] = gfc_index_one_node;
3082   else
3083     {
3084       gfc_init_se (&se, NULL);
3085       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3086       gfc_add_block_to_block (&loop->pre, &se.pre);
3087       info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3088     }
3089 }
3090
3091
3092 /* Calculates the range start and stride for a SS chain.  Also gets the
3093    descriptor and data pointer.  The range of vector subscripts is the size
3094    of the vector.  Array bounds are also checked.  */
3095
3096 void
3097 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3098 {
3099   int n;
3100   tree tmp;
3101   gfc_ss *ss;
3102   tree desc;
3103
3104   loop->dimen = 0;
3105   /* Determine the rank of the loop.  */
3106   for (ss = loop->ss;
3107        ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3108     {
3109       switch (ss->type)
3110         {
3111         case GFC_SS_SECTION:
3112         case GFC_SS_CONSTRUCTOR:
3113         case GFC_SS_FUNCTION:
3114         case GFC_SS_COMPONENT:
3115           loop->dimen = ss->data.info.dimen;
3116           break;
3117
3118         /* As usual, lbound and ubound are exceptions!.  */
3119         case GFC_SS_INTRINSIC:
3120           switch (ss->expr->value.function.isym->id)
3121             {
3122             case GFC_ISYM_LBOUND:
3123             case GFC_ISYM_UBOUND:
3124               loop->dimen = ss->data.info.dimen;
3125
3126             default:
3127               break;
3128             }
3129
3130         default:
3131           break;
3132         }
3133     }
3134
3135   /* We should have determined the rank of the expression by now.  If
3136      not, that's bad news.  */
3137   gcc_assert (loop->dimen != 0);
3138
3139   /* Loop over all the SS in the chain.  */
3140   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3141     {
3142       if (ss->expr && ss->expr->shape && !ss->shape)
3143         ss->shape = ss->expr->shape;
3144
3145       switch (ss->type)
3146         {
3147         case GFC_SS_SECTION:
3148           /* Get the descriptor for the array.  */
3149           gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3150
3151           for (n = 0; n < ss->data.info.dimen; n++)
3152             gfc_conv_section_startstride (loop, ss, n);
3153           break;
3154
3155         case GFC_SS_INTRINSIC:
3156           switch (ss->expr->value.function.isym->id)
3157             {
3158             /* Fall through to supply start and stride.  */
3159             case GFC_ISYM_LBOUND:
3160             case GFC_ISYM_UBOUND:
3161               break;
3162             default:
3163               continue;
3164             }
3165
3166         case GFC_SS_CONSTRUCTOR:
3167         case GFC_SS_FUNCTION:
3168           for (n = 0; n < ss->data.info.dimen; n++)
3169             {
3170               ss->data.info.start[n] = gfc_index_zero_node;
3171               ss->data.info.end[n] = gfc_index_zero_node;
3172               ss->data.info.stride[n] = gfc_index_one_node;
3173             }
3174           break;
3175
3176         default:
3177           break;
3178         }
3179     }
3180
3181   /* The rest is just runtime bound checking.  */
3182   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3183     {
3184       stmtblock_t block;
3185       tree lbound, ubound;
3186       tree end;
3187       tree size[GFC_MAX_DIMENSIONS];
3188       tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3189       gfc_ss_info *info;
3190       char *msg;
3191       int dim;
3192
3193       gfc_start_block (&block);
3194
3195       for (n = 0; n < loop->dimen; n++)
3196         size[n] = NULL_TREE;
3197
3198       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3199         {
3200           stmtblock_t inner;
3201
3202           if (ss->type != GFC_SS_SECTION)
3203             continue;
3204
3205           gfc_start_block (&inner);
3206
3207           /* TODO: range checking for mapped dimensions.  */
3208           info = &ss->data.info;
3209
3210           /* This code only checks ranges.  Elemental and vector
3211              dimensions are checked later.  */
3212           for (n = 0; n < loop->dimen; n++)
3213             {
3214               bool check_upper;
3215
3216               dim = info->dim[n];
3217               if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3218                 continue;
3219
3220               if (dim == info->ref->u.ar.dimen - 1
3221                   && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3222                 check_upper = false;
3223               else
3224                 check_upper = true;
3225
3226               /* Zero stride is not allowed.  */
3227               tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3228                                  gfc_index_zero_node);
3229               asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3230                         "of array '%s'", info->dim[n]+1,
3231                         ss->expr->symtree->name);
3232               gfc_trans_runtime_check (true, false, tmp, &inner,
3233                                        &ss->expr->where, msg);
3234               gfc_free (msg);
3235
3236               desc = ss->data.info.descriptor;
3237
3238               /* This is the run-time equivalent of resolve.c's
3239                  check_dimension().  The logical is more readable there
3240                  than it is here, with all the trees.  */
3241               lbound = gfc_conv_array_lbound (desc, dim);
3242               end = info->end[n];
3243               if (check_upper)
3244                 ubound = gfc_conv_array_ubound (desc, dim);
3245               else
3246                 ubound = NULL;
3247
3248               /* non_zerosized is true when the selected range is not
3249                  empty.  */
3250               stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3251                                         info->stride[n], gfc_index_zero_node);
3252               tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3253                                  end);
3254               stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3255                                         stride_pos, tmp);
3256
3257               stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3258                                         info->stride[n], gfc_index_zero_node);
3259               tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3260                                  end);
3261               stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3262                                         stride_neg, tmp);
3263               non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3264                                            stride_pos, stride_neg);
3265
3266               /* Check the start of the range against the lower and upper
3267                  bounds of the array, if the range is not empty. 
3268                  If upper bound is present, include both bounds in the 
3269                  error message.  */
3270               if (check_upper)
3271                 {
3272                   tmp = fold_build2 (LT_EXPR, boolean_type_node, 
3273                                      info->start[n], lbound);
3274                   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3275                                      non_zerosized, tmp);
3276                   tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3277                                       info->start[n], ubound);
3278                   tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3279                                       non_zerosized, tmp2);
3280                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3281                             "outside of expected range (%%ld:%%ld)", 
3282                             info->dim[n]+1, ss->expr->symtree->name);
3283                   gfc_trans_runtime_check (true, false, tmp, &inner, 
3284                                            &ss->expr->where, msg,
3285                      fold_convert (long_integer_type_node, info->start[n]),
3286                      fold_convert (long_integer_type_node, lbound), 
3287                      fold_convert (long_integer_type_node, ubound));
3288                   gfc_trans_runtime_check (true, false, tmp2, &inner, 
3289                                            &ss->expr->where, msg,
3290                      fold_convert (long_integer_type_node, info->start[n]),
3291                      fold_convert (long_integer_type_node, lbound), 
3292                      fold_convert (long_integer_type_node, ubound));
3293                   gfc_free (msg);
3294                 }
3295               else
3296                 {
3297                   tmp = fold_build2 (LT_EXPR, boolean_type_node, 
3298                                      info->start[n], lbound);
3299                   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3300                                      non_zerosized, tmp);
3301                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3302                             "below lower bound of %%ld", 
3303                             info->dim[n]+1, ss->expr->symtree->name);
3304                   gfc_trans_runtime_check (true, false, tmp, &inner, 
3305                                            &ss->expr->where, msg,
3306                      fold_convert (long_integer_type_node, info->start[n]),
3307                      fold_convert (long_integer_type_node, lbound));
3308                   gfc_free (msg);
3309                 }
3310               
3311               /* Compute the last element of the range, which is not
3312                  necessarily "end" (think 0:5:3, which doesn't contain 5)
3313                  and check it against both lower and upper bounds.  */
3314
3315               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3316                                   info->start[n]);
3317               tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3318                                   info->stride[n]);
3319               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3320                                   tmp);
3321               tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3322               tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3323                                  non_zerosized, tmp2);
3324               if (check_upper)
3325                 {
3326                   tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3327                   tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3328                                       non_zerosized, tmp3);
3329                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3330                             "outside of expected range (%%ld:%%ld)", 
3331                             info->dim[n]+1, ss->expr->symtree->name);
3332                   gfc_trans_runtime_check (true, false, tmp2, &inner,
3333                                            &ss->expr->where, msg,
3334                      fold_convert (long_integer_type_node, tmp),
3335                      fold_convert (long_integer_type_node, ubound), 
3336                      fold_convert (long_integer_type_node, lbound));
3337                   gfc_trans_runtime_check (true, false, tmp3, &inner,
3338                                            &ss->expr->where, msg,
3339                      fold_convert (long_integer_type_node, tmp),
3340                      fold_convert (long_integer_type_node, ubound), 
3341                      fold_convert (long_integer_type_node, lbound));
3342                   gfc_free (msg);
3343                 }
3344               else
3345                 {
3346                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3347                             "below lower bound of %%ld", 
3348                             info->dim[n]+1, ss->expr->symtree->name);
3349                   gfc_trans_runtime_check (true, false, tmp2, &inner,
3350                                            &ss->expr->where, msg,
3351                      fold_convert (long_integer_type_node, tmp),
3352                      fold_convert (long_integer_type_node, lbound));
3353                   gfc_free (msg);
3354                 }
3355               
3356               /* Check the section sizes match.  */
3357               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3358                                  info->start[n]);
3359               tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3360                                  info->stride[n]);
3361               tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3362                                  gfc_index_one_node, tmp);
3363               tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3364                                  build_int_cst (gfc_array_index_type, 0));
3365               /* We remember the size of the first section, and check all the
3366                  others against this.  */
3367               if (size[n])
3368                 {
3369                   tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3370                   asprintf (&msg, "Array bound mismatch for dimension %d "
3371                             "of array '%s' (%%ld/%%ld)",
3372                             info->dim[n]+1, ss->expr->symtree->name);
3373
3374                   gfc_trans_runtime_check (true, false, tmp3, &inner,
3375                                            &ss->expr->where, msg,
3376                         fold_convert (long_integer_type_node, tmp),
3377                         fold_convert (long_integer_type_node, size[n]));
3378
3379                   gfc_free (msg);
3380                 }
3381               else
3382