OSDN Git Service

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