OSDN Git Service

b03cc9400c92649410a1a2baed89325791680d61
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-array.c
1 /* Array translation routines
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Paul Brook <paul@nowt.org>
5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23 /* trans-array.c-- Various array related code, including scalarization,
24                    allocation, initialization and other support routines.  */
25
26 /* How the scalarizer works.
27    In gfortran, array expressions use the same core routines as scalar
28    expressions.
29    First, a Scalarization State (SS) chain is built.  This is done by walking
30    the expression tree, and building a linear list of the terms in the
31    expression.  As the tree is walked, scalar subexpressions are translated.
32
33    The scalarization parameters are stored in a gfc_loopinfo structure.
34    First the start and stride of each term is calculated by
35    gfc_conv_ss_startstride.  During this process the expressions for the array
36    descriptors and data pointers are also translated.
37
38    If the expression is an assignment, we must then resolve any dependencies.
39    In fortran all the rhs values of an assignment must be evaluated before
40    any assignments take place.  This can require a temporary array to store the
41    values.  We also require a temporary when we are passing array expressions
42    or vector subscripts as procedure parameters.
43
44    Array sections are passed without copying to a temporary.  These use the
45    scalarizer to determine the shape of the section.  The flag
46    loop->array_parameter tells the scalarizer that the actual values and loop
47    variables will not be required.
48
49    The function gfc_conv_loop_setup generates the scalarization setup code.
50    It determines the range of the scalarizing loop variables.  If a temporary
51    is required, this is created and initialized.  Code for scalar expressions
52    taken outside the loop is also generated at this time.  Next the offset and
53    scaling required to translate from loop variables to array indices for each
54    term is calculated.
55
56    A call to gfc_start_scalarized_body marks the start of the scalarized
57    expression.  This creates a scope and declares the loop variables.  Before
58    calling this gfc_make_ss_chain_used must be used to indicate which terms
59    will be used inside this loop.
60
61    The scalar gfc_conv_* functions are then used to build the main body of the
62    scalarization loop.  Scalarization loop variables and precalculated scalar
63    values are automatically substituted.  Note that gfc_advance_se_ss_chain
64    must be used, rather than changing the se->ss directly.
65
66    For assignment expressions requiring a temporary two sub loops are
67    generated.  The first stores the result of the expression in the temporary,
68    the second copies it to the result.  A call to
69    gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
70    the start of the copying loop.  The temporary may be less than full rank.
71
72    Finally gfc_trans_scalarizing_loops is called to generate the implicit do
73    loops.  The loops are added to the pre chain of the loopinfo.  The post
74    chain may still contain cleanup code.
75
76    After the loop code has been added into its parent scope gfc_cleanup_loop
77    is called to free all the SS allocated by the scalarizer.  */
78
79 #include "config.h"
80 #include "system.h"
81 #include "coretypes.h"
82 #include "tree.h"
83 #include "gimple.h"
84 #include "ggc.h"
85 #include "toplev.h"
86 #include "real.h"
87 #include "flags.h"
88 #include "gfortran.h"
89 #include "constructor.h"
90 #include "trans.h"
91 #include "trans-stmt.h"
92 #include "trans-types.h"
93 #include "trans-array.h"
94 #include "trans-const.h"
95 #include "dependency.h"
96
97 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
98 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
99
100 /* The contents of this structure aren't actually used, just the address.  */
101 static gfc_ss gfc_ss_terminator_var;
102 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
103
104
105 static tree
106 gfc_array_dataptr_type (tree desc)
107 {
108   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
109 }
110
111
112 /* Build expressions to access the members of an array descriptor.
113    It's surprisingly easy to mess up here, so never access
114    an array descriptor by "brute force", always use these
115    functions.  This also avoids problems if we change the format
116    of an array descriptor.
117
118    To understand these magic numbers, look at the comments
119    before gfc_build_array_type() in trans-types.c.
120
121    The code within these defines should be the only code which knows the format
122    of an array descriptor.
123
124    Any code just needing to read obtain the bounds of an array should use
125    gfc_conv_array_* rather than the following functions as these will return
126    know constant values, and work with arrays which do not have descriptors.
127
128    Don't forget to #undef these!  */
129
130 #define DATA_FIELD 0
131 #define OFFSET_FIELD 1
132 #define DTYPE_FIELD 2
133 #define DIMENSION_FIELD 3
134
135 #define STRIDE_SUBFIELD 0
136 #define LBOUND_SUBFIELD 1
137 #define UBOUND_SUBFIELD 2
138
139 /* This provides READ-ONLY access to the data field.  The field itself
140    doesn't have the proper type.  */
141
142 tree
143 gfc_conv_descriptor_data_get (tree desc)
144 {
145   tree field, type, t;
146
147   type = TREE_TYPE (desc);
148   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
149
150   field = TYPE_FIELDS (type);
151   gcc_assert (DATA_FIELD == 0);
152
153   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
154   t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
155
156   return t;
157 }
158
159 /* This provides WRITE access to the data field.
160
161    TUPLES_P is true if we are generating tuples.
162    
163    This function gets called through the following macros:
164      gfc_conv_descriptor_data_set
165      gfc_conv_descriptor_data_set.  */
166
167 void
168 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
169 {
170   tree field, type, t;
171
172   type = TREE_TYPE (desc);
173   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
174
175   field = TYPE_FIELDS (type);
176   gcc_assert (DATA_FIELD == 0);
177
178   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
179   gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
180 }
181
182
183 /* This provides address access to the data field.  This should only be
184    used by array allocation, passing this on to the runtime.  */
185
186 tree
187 gfc_conv_descriptor_data_addr (tree desc)
188 {
189   tree field, type, t;
190
191   type = TREE_TYPE (desc);
192   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
193
194   field = TYPE_FIELDS (type);
195   gcc_assert (DATA_FIELD == 0);
196
197   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
198   return gfc_build_addr_expr (NULL_TREE, t);
199 }
200
201 static tree
202 gfc_conv_descriptor_offset (tree desc)
203 {
204   tree type;
205   tree field;
206
207   type = TREE_TYPE (desc);
208   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209
210   field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212
213   return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
214                       desc, field, NULL_TREE);
215 }
216
217 tree
218 gfc_conv_descriptor_offset_get (tree desc)
219 {
220   return gfc_conv_descriptor_offset (desc);
221 }
222
223 void
224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
225                                 tree value)
226 {
227   tree t = gfc_conv_descriptor_offset (desc);
228   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
229 }
230
231
232 tree
233 gfc_conv_descriptor_dtype (tree desc)
234 {
235   tree field;
236   tree type;
237
238   type = TREE_TYPE (desc);
239   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240
241   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
243
244   return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
245                       desc, field, NULL_TREE);
246 }
247
248 static tree
249 gfc_conv_descriptor_dimension (tree desc, tree dim)
250 {
251   tree field;
252   tree type;
253   tree tmp;
254
255   type = TREE_TYPE (desc);
256   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
257
258   field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
259   gcc_assert (field != NULL_TREE
260           && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
261           && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
262
263   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
264                      desc, field, NULL_TREE);
265   tmp = gfc_build_array_ref (tmp, dim, NULL);
266   return tmp;
267 }
268
269 static tree
270 gfc_conv_descriptor_stride (tree desc, tree dim)
271 {
272   tree tmp;
273   tree field;
274
275   tmp = gfc_conv_descriptor_dimension (desc, dim);
276   field = TYPE_FIELDS (TREE_TYPE (tmp));
277   field = gfc_advance_chain (field, STRIDE_SUBFIELD);
278   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
279
280   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
281                      tmp, field, NULL_TREE);
282   return tmp;
283 }
284
285 tree
286 gfc_conv_descriptor_stride_get (tree desc, tree dim)
287 {
288   tree type = TREE_TYPE (desc);
289   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
290   if (integer_zerop (dim)
291       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
292     return gfc_index_one_node;
293
294   return gfc_conv_descriptor_stride (desc, dim);
295 }
296
297 void
298 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
299                                 tree dim, tree value)
300 {
301   tree t = gfc_conv_descriptor_stride (desc, dim);
302   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
303 }
304
305 static tree
306 gfc_conv_descriptor_lbound (tree desc, tree dim)
307 {
308   tree tmp;
309   tree field;
310
311   tmp = gfc_conv_descriptor_dimension (desc, dim);
312   field = TYPE_FIELDS (TREE_TYPE (tmp));
313   field = gfc_advance_chain (field, LBOUND_SUBFIELD);
314   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
315
316   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
317                      tmp, field, NULL_TREE);
318   return tmp;
319 }
320
321 tree
322 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
323 {
324   return gfc_conv_descriptor_lbound (desc, dim);
325 }
326
327 void
328 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
329                                 tree dim, tree value)
330 {
331   tree t = gfc_conv_descriptor_lbound (desc, dim);
332   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
333 }
334
335 static tree
336 gfc_conv_descriptor_ubound (tree desc, tree dim)
337 {
338   tree tmp;
339   tree field;
340
341   tmp = gfc_conv_descriptor_dimension (desc, dim);
342   field = TYPE_FIELDS (TREE_TYPE (tmp));
343   field = gfc_advance_chain (field, UBOUND_SUBFIELD);
344   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
345
346   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
347                      tmp, field, NULL_TREE);
348   return tmp;
349 }
350
351 tree
352 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
353 {
354   return gfc_conv_descriptor_ubound (desc, dim);
355 }
356
357 void
358 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
359                                 tree dim, tree value)
360 {
361   tree t = gfc_conv_descriptor_ubound (desc, dim);
362   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
363 }
364
365 /* Build a null array descriptor constructor.  */
366
367 tree
368 gfc_build_null_descriptor (tree type)
369 {
370   tree field;
371   tree tmp;
372
373   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
374   gcc_assert (DATA_FIELD == 0);
375   field = TYPE_FIELDS (type);
376
377   /* Set a NULL data pointer.  */
378   tmp = build_constructor_single (type, field, null_pointer_node);
379   TREE_CONSTANT (tmp) = 1;
380   /* All other fields are ignored.  */
381
382   return tmp;
383 }
384
385
386 /* Cleanup those #defines.  */
387
388 #undef DATA_FIELD
389 #undef OFFSET_FIELD
390 #undef DTYPE_FIELD
391 #undef DIMENSION_FIELD
392 #undef STRIDE_SUBFIELD
393 #undef LBOUND_SUBFIELD
394 #undef UBOUND_SUBFIELD
395
396
397 /* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
398    flags & 1 = Main loop body.
399    flags & 2 = temp copy loop.  */
400
401 void
402 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
403 {
404   for (; ss != gfc_ss_terminator; ss = ss->next)
405     ss->useflags = flags;
406 }
407
408 static void gfc_free_ss (gfc_ss *);
409
410
411 /* Free a gfc_ss chain.  */
412
413 static void
414 gfc_free_ss_chain (gfc_ss * ss)
415 {
416   gfc_ss *next;
417
418   while (ss != gfc_ss_terminator)
419     {
420       gcc_assert (ss != NULL);
421       next = ss->next;
422       gfc_free_ss (ss);
423       ss = next;
424     }
425 }
426
427
428 /* Free a SS.  */
429
430 static void
431 gfc_free_ss (gfc_ss * ss)
432 {
433   int n;
434
435   switch (ss->type)
436     {
437     case GFC_SS_SECTION:
438       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
439         {
440           if (ss->data.info.subscript[n])
441             gfc_free_ss_chain (ss->data.info.subscript[n]);
442         }
443       break;
444
445     default:
446       break;
447     }
448
449   gfc_free (ss);
450 }
451
452
453 /* Free all the SS associated with a loop.  */
454
455 void
456 gfc_cleanup_loop (gfc_loopinfo * loop)
457 {
458   gfc_ss *ss;
459   gfc_ss *next;
460
461   ss = loop->ss;
462   while (ss != gfc_ss_terminator)
463     {
464       gcc_assert (ss != NULL);
465       next = ss->loop_chain;
466       gfc_free_ss (ss);
467       ss = next;
468     }
469 }
470
471
472 /* Associate a SS chain with a loop.  */
473
474 void
475 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
476 {
477   gfc_ss *ss;
478
479   if (head == gfc_ss_terminator)
480     return;
481
482   ss = head;
483   for (; ss && ss != gfc_ss_terminator; ss = ss->next)
484     {
485       if (ss->next == gfc_ss_terminator)
486         ss->loop_chain = loop->ss;
487       else
488         ss->loop_chain = ss->next;
489     }
490   gcc_assert (ss == gfc_ss_terminator);
491   loop->ss = head;
492 }
493
494
495 /* Generate an initializer for a static pointer or allocatable array.  */
496
497 void
498 gfc_trans_static_array_pointer (gfc_symbol * sym)
499 {
500   tree type;
501
502   gcc_assert (TREE_STATIC (sym->backend_decl));
503   /* Just zero the data member.  */
504   type = TREE_TYPE (sym->backend_decl);
505   DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
506 }
507
508
509 /* If the bounds of SE's loop have not yet been set, see if they can be
510    determined from array spec AS, which is the array spec of a called
511    function.  MAPPING maps the callee's dummy arguments to the values
512    that the caller is passing.  Add any initialization and finalization
513    code to SE.  */
514
515 void
516 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
517                                      gfc_se * se, gfc_array_spec * as)
518 {
519   int n, dim;
520   gfc_se tmpse;
521   tree lower;
522   tree upper;
523   tree tmp;
524
525   if (as && as->type == AS_EXPLICIT)
526     for (dim = 0; dim < se->loop->dimen; dim++)
527       {
528         n = se->loop->order[dim];
529         if (se->loop->to[n] == NULL_TREE)
530           {
531             /* Evaluate the lower bound.  */
532             gfc_init_se (&tmpse, NULL);
533             gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
534             gfc_add_block_to_block (&se->pre, &tmpse.pre);
535             gfc_add_block_to_block (&se->post, &tmpse.post);
536             lower = fold_convert (gfc_array_index_type, tmpse.expr);
537
538             /* ...and the upper bound.  */
539             gfc_init_se (&tmpse, NULL);
540             gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
541             gfc_add_block_to_block (&se->pre, &tmpse.pre);
542             gfc_add_block_to_block (&se->post, &tmpse.post);
543             upper = fold_convert (gfc_array_index_type, tmpse.expr);
544
545             /* Set the upper bound of the loop to UPPER - LOWER.  */
546             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
547             tmp = gfc_evaluate_now (tmp, &se->pre);
548             se->loop->to[n] = tmp;
549           }
550       }
551 }
552
553
554 /* Generate code to allocate an array temporary, or create a variable to
555    hold the data.  If size is NULL, zero the descriptor so that the
556    callee will allocate the array.  If DEALLOC is true, also generate code to
557    free the array afterwards.
558
559    If INITIAL is not NULL, it is packed using internal_pack and the result used
560    as data instead of allocating a fresh, unitialized area of memory.
561
562    Initialization code is added to PRE and finalization code to POST.
563    DYNAMIC is true if the caller may want to extend the array later
564    using realloc.  This prevents us from putting the array on the stack.  */
565
566 static void
567 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
568                                   gfc_ss_info * info, tree size, tree nelem,
569                                   tree initial, bool dynamic, bool dealloc)
570 {
571   tree tmp;
572   tree desc;
573   bool onstack;
574
575   desc = info->descriptor;
576   info->offset = gfc_index_zero_node;
577   if (size == NULL_TREE || integer_zerop (size))
578     {
579       /* A callee allocated array.  */
580       gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
581       onstack = FALSE;
582     }
583   else
584     {
585       /* Allocate the temporary.  */
586       onstack = !dynamic && initial == NULL_TREE
587                          && gfc_can_put_var_on_stack (size);
588
589       if (onstack)
590         {
591           /* Make a temporary variable to hold the data.  */
592           tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
593                              gfc_index_one_node);
594           tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
595                                   tmp);
596           tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
597                                   tmp);
598           tmp = gfc_create_var (tmp, "A");
599           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
600           gfc_conv_descriptor_data_set (pre, desc, tmp);
601         }
602       else
603         {
604           /* Allocate memory to hold the data or call internal_pack.  */
605           if (initial == NULL_TREE)
606             {
607               tmp = gfc_call_malloc (pre, NULL, size);
608               tmp = gfc_evaluate_now (tmp, pre);
609             }
610           else
611             {
612               tree packed;
613               tree source_data;
614               tree was_packed;
615               stmtblock_t do_copying;
616
617               tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
618               gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
619               tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
620               tmp = gfc_get_element_type (tmp);
621               gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
622               packed = gfc_create_var (build_pointer_type (tmp), "data");
623
624               tmp = build_call_expr_loc (input_location,
625                                      gfor_fndecl_in_pack, 1, initial);
626               tmp = fold_convert (TREE_TYPE (packed), tmp);
627               gfc_add_modify (pre, packed, tmp);
628
629               tmp = build_fold_indirect_ref_loc (input_location,
630                                              initial);
631               source_data = gfc_conv_descriptor_data_get (tmp);
632
633               /* internal_pack may return source->data without any allocation
634                  or copying if it is already packed.  If that's the case, we
635                  need to allocate and copy manually.  */
636
637               gfc_start_block (&do_copying);
638               tmp = gfc_call_malloc (&do_copying, NULL, size);
639               tmp = fold_convert (TREE_TYPE (packed), tmp);
640               gfc_add_modify (&do_copying, packed, tmp);
641               tmp = gfc_build_memcpy_call (packed, source_data, size);
642               gfc_add_expr_to_block (&do_copying, tmp);
643
644               was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
645                                         packed, source_data);
646               tmp = gfc_finish_block (&do_copying);
647               tmp = build3_v (COND_EXPR, was_packed, tmp,
648                               build_empty_stmt (input_location));
649               gfc_add_expr_to_block (pre, tmp);
650
651               tmp = fold_convert (pvoid_type_node, packed);
652             }
653
654           gfc_conv_descriptor_data_set (pre, desc, tmp);
655         }
656     }
657   info->data = gfc_conv_descriptor_data_get (desc);
658
659   /* The offset is zero because we create temporaries with a zero
660      lower bound.  */
661   gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
662
663   if (dealloc && !onstack)
664     {
665       /* Free the temporary.  */
666       tmp = gfc_conv_descriptor_data_get (desc);
667       tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
668       gfc_add_expr_to_block (post, tmp);
669     }
670 }
671
672
673 /* Generate code to create and initialize the descriptor for a temporary
674    array.  This is used for both temporaries needed by the scalarizer, and
675    functions returning arrays.  Adjusts the loop variables to be
676    zero-based, and calculates the loop bounds for callee allocated arrays.
677    Allocate the array unless it's callee allocated (we have a callee
678    allocated array if 'callee_alloc' is true, or if loop->to[n] is
679    NULL_TREE for any n).  Also fills in the descriptor, data and offset
680    fields of info if known.  Returns the size of the array, or NULL for a
681    callee allocated array.
682
683    PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
684    gfc_trans_allocate_array_storage.
685  */
686
687 tree
688 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
689                              gfc_loopinfo * loop, gfc_ss_info * info,
690                              tree eltype, tree initial, bool dynamic,
691                              bool dealloc, bool callee_alloc, locus * where)
692 {
693   tree type;
694   tree desc;
695   tree tmp;
696   tree size;
697   tree nelem;
698   tree cond;
699   tree or_expr;
700   int n;
701   int dim;
702
703   gcc_assert (info->dimen > 0);
704
705   if (gfc_option.warn_array_temp && where)
706     gfc_warning ("Creating array temporary at %L", where);
707
708   /* Set the lower bound to zero.  */
709   for (dim = 0; dim < info->dimen; dim++)
710     {
711       n = loop->order[dim];
712       /* Callee allocated arrays may not have a known bound yet.  */
713       if (loop->to[n])
714         loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
715                                         gfc_array_index_type,
716                                         loop->to[n], loop->from[n]), pre);
717       loop->from[n] = gfc_index_zero_node;
718
719       info->delta[dim] = gfc_index_zero_node;
720       info->start[dim] = gfc_index_zero_node;
721       info->end[dim] = gfc_index_zero_node;
722       info->stride[dim] = gfc_index_one_node;
723       info->dim[dim] = dim;
724     }
725
726   /* Initialize the descriptor.  */
727   type =
728     gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
729                                GFC_ARRAY_UNKNOWN, true);
730   desc = gfc_create_var (type, "atmp");
731   GFC_DECL_PACKED_ARRAY (desc) = 1;
732
733   info->descriptor = desc;
734   size = gfc_index_one_node;
735
736   /* Fill in the array dtype.  */
737   tmp = gfc_conv_descriptor_dtype (desc);
738   gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
739
740   /*
741      Fill in the bounds and stride.  This is a packed array, so:
742
743      size = 1;
744      for (n = 0; n < rank; n++)
745        {
746          stride[n] = size
747          delta = ubound[n] + 1 - lbound[n];
748          size = size * delta;
749        }
750      size = size * sizeof(element);
751   */
752
753   or_expr = NULL_TREE;
754
755   /* If there is at least one null loop->to[n], it is a callee allocated 
756      array.  */
757   for (n = 0; n < info->dimen; n++)
758     if (loop->to[n] == NULL_TREE)
759       {
760         size = NULL_TREE;
761         break;
762       }
763
764   for (n = 0; n < info->dimen; n++)
765      {
766       if (size == NULL_TREE)
767         {
768           /* For a callee allocated array express the loop bounds in terms
769              of the descriptor fields.  */
770           tmp =
771             fold_build2 (MINUS_EXPR, gfc_array_index_type,
772                          gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
773                          gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
774           loop->to[n] = tmp;
775           continue;
776         }
777         
778       /* Store the stride and bound components in the descriptor.  */
779       gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
780
781       gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
782                                       gfc_index_zero_node);
783
784       gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
785
786       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
787                          loop->to[n], gfc_index_one_node);
788
789       /* Check whether the size for this dimension is negative.  */
790       cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
791                           gfc_index_zero_node);
792       cond = gfc_evaluate_now (cond, pre);
793
794       if (n == 0)
795         or_expr = cond;
796       else
797         or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
798
799       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
800       size = gfc_evaluate_now (size, pre);
801     }
802
803   /* Get the size of the array.  */
804
805   if (size && !callee_alloc)
806     {
807       /* If or_expr is true, then the extent in at least one
808          dimension is zero and the size is set to zero.  */
809       size = fold_build3 (COND_EXPR, gfc_array_index_type,
810                           or_expr, gfc_index_zero_node, size);
811
812       nelem = size;
813       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
814                 fold_convert (gfc_array_index_type,
815                               TYPE_SIZE_UNIT (gfc_get_element_type (type))));
816     }
817   else
818     {
819       nelem = size;
820       size = NULL_TREE;
821     }
822
823   gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
824                                     dynamic, dealloc);
825
826   if (info->dimen > loop->temp_dim)
827     loop->temp_dim = info->dimen;
828
829   return size;
830 }
831
832
833 /* Generate code to transpose array EXPR by creating a new descriptor
834    in which the dimension specifications have been reversed.  */
835
836 void
837 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
838 {
839   tree dest, src, dest_index, src_index;
840   gfc_loopinfo *loop;
841   gfc_ss_info *dest_info;
842   gfc_ss *dest_ss, *src_ss;
843   gfc_se src_se;
844   int n;
845
846   loop = se->loop;
847
848   src_ss = gfc_walk_expr (expr);
849   dest_ss = se->ss;
850
851   dest_info = &dest_ss->data.info;
852   gcc_assert (dest_info->dimen == 2);
853
854   /* Get a descriptor for EXPR.  */
855   gfc_init_se (&src_se, NULL);
856   gfc_conv_expr_descriptor (&src_se, expr, src_ss);
857   gfc_add_block_to_block (&se->pre, &src_se.pre);
858   gfc_add_block_to_block (&se->post, &src_se.post);
859   src = src_se.expr;
860
861   /* Allocate a new descriptor for the return value.  */
862   dest = gfc_create_var (TREE_TYPE (src), "atmp");
863   dest_info->descriptor = dest;
864   se->expr = dest;
865
866   /* Copy across the dtype field.  */
867   gfc_add_modify (&se->pre,
868                        gfc_conv_descriptor_dtype (dest),
869                        gfc_conv_descriptor_dtype (src));
870
871   /* Copy the dimension information, renumbering dimension 1 to 0 and
872      0 to 1.  */
873   for (n = 0; n < 2; n++)
874     {
875       dest_info->delta[n] = gfc_index_zero_node;
876       dest_info->start[n] = gfc_index_zero_node;
877       dest_info->end[n] = gfc_index_zero_node;
878       dest_info->stride[n] = gfc_index_one_node;
879       dest_info->dim[n] = n;
880
881       dest_index = gfc_rank_cst[n];
882       src_index = gfc_rank_cst[1 - n];
883
884       gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
885                            gfc_conv_descriptor_stride_get (src, src_index));
886
887       gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
888                            gfc_conv_descriptor_lbound_get (src, src_index));
889
890       gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
891                            gfc_conv_descriptor_ubound_get (src, src_index));
892
893       if (!loop->to[n])
894         {
895           gcc_assert (integer_zerop (loop->from[n]));
896           loop->to[n] =
897             fold_build2 (MINUS_EXPR, gfc_array_index_type,
898                          gfc_conv_descriptor_ubound_get (dest, dest_index),
899                          gfc_conv_descriptor_lbound_get (dest, dest_index));
900         }
901     }
902
903   /* Copy the data pointer.  */
904   dest_info->data = gfc_conv_descriptor_data_get (src);
905   gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
906
907   /* Copy the offset.  This is not changed by transposition; the top-left
908      element is still at the same offset as before, except where the loop
909      starts at zero.  */
910   if (!integer_zerop (loop->from[0]))
911     dest_info->offset = gfc_conv_descriptor_offset_get (src);
912   else
913     dest_info->offset = gfc_index_zero_node;
914
915   gfc_conv_descriptor_offset_set (&se->pre, dest,
916                                   dest_info->offset);
917           
918   if (dest_info->dimen > loop->temp_dim)
919     loop->temp_dim = dest_info->dimen;
920 }
921
922
923 /* Return the number of iterations in a loop that starts at START,
924    ends at END, and has step STEP.  */
925
926 static tree
927 gfc_get_iteration_count (tree start, tree end, tree step)
928 {
929   tree tmp;
930   tree type;
931
932   type = TREE_TYPE (step);
933   tmp = fold_build2 (MINUS_EXPR, type, end, start);
934   tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
935   tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
936   tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
937   return fold_convert (gfc_array_index_type, tmp);
938 }
939
940
941 /* Extend the data in array DESC by EXTRA elements.  */
942
943 static void
944 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
945 {
946   tree arg0, arg1;
947   tree tmp;
948   tree size;
949   tree ubound;
950
951   if (integer_zerop (extra))
952     return;
953
954   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
955
956   /* Add EXTRA to the upper bound.  */
957   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
958   gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
959
960   /* Get the value of the current data pointer.  */
961   arg0 = gfc_conv_descriptor_data_get (desc);
962
963   /* Calculate the new array size.  */
964   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
965   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
966                      ubound, gfc_index_one_node);
967   arg1 = fold_build2 (MULT_EXPR, size_type_node,
968                        fold_convert (size_type_node, tmp),
969                        fold_convert (size_type_node, size));
970
971   /* Call the realloc() function.  */
972   tmp = gfc_call_realloc (pblock, arg0, arg1);
973   gfc_conv_descriptor_data_set (pblock, desc, tmp);
974 }
975
976
977 /* Return true if the bounds of iterator I can only be determined
978    at run time.  */
979
980 static inline bool
981 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
982 {
983   return (i->start->expr_type != EXPR_CONSTANT
984           || i->end->expr_type != EXPR_CONSTANT
985           || i->step->expr_type != EXPR_CONSTANT);
986 }
987
988
989 /* Split the size of constructor element EXPR into the sum of two terms,
990    one of which can be determined at compile time and one of which must
991    be calculated at run time.  Set *SIZE to the former and return true
992    if the latter might be nonzero.  */
993
994 static bool
995 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
996 {
997   if (expr->expr_type == EXPR_ARRAY)
998     return gfc_get_array_constructor_size (size, expr->value.constructor);
999   else if (expr->rank > 0)
1000     {
1001       /* Calculate everything at run time.  */
1002       mpz_set_ui (*size, 0);
1003       return true;
1004     }
1005   else
1006     {
1007       /* A single element.  */
1008       mpz_set_ui (*size, 1);
1009       return false;
1010     }
1011 }
1012
1013
1014 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1015    of array constructor C.  */
1016
1017 static bool
1018 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1019 {
1020   gfc_constructor *c;
1021   gfc_iterator *i;
1022   mpz_t val;
1023   mpz_t len;
1024   bool dynamic;
1025
1026   mpz_set_ui (*size, 0);
1027   mpz_init (len);
1028   mpz_init (val);
1029
1030   dynamic = false;
1031   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1032     {
1033       i = c->iterator;
1034       if (i && gfc_iterator_has_dynamic_bounds (i))
1035         dynamic = true;
1036       else
1037         {
1038           dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1039           if (i)
1040             {
1041               /* Multiply the static part of the element size by the
1042                  number of iterations.  */
1043               mpz_sub (val, i->end->value.integer, i->start->value.integer);
1044               mpz_fdiv_q (val, val, i->step->value.integer);
1045               mpz_add_ui (val, val, 1);
1046               if (mpz_sgn (val) > 0)
1047                 mpz_mul (len, len, val);
1048               else
1049                 mpz_set_ui (len, 0);
1050             }
1051           mpz_add (*size, *size, len);
1052         }
1053     }
1054   mpz_clear (len);
1055   mpz_clear (val);
1056   return dynamic;
1057 }
1058
1059
1060 /* Make sure offset is a variable.  */
1061
1062 static void
1063 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1064                          tree * offsetvar)
1065 {
1066   /* We should have already created the offset variable.  We cannot
1067      create it here because we may be in an inner scope.  */
1068   gcc_assert (*offsetvar != NULL_TREE);
1069   gfc_add_modify (pblock, *offsetvar, *poffset);
1070   *poffset = *offsetvar;
1071   TREE_USED (*offsetvar) = 1;
1072 }
1073
1074
1075 /* Variables needed for bounds-checking.  */
1076 static bool first_len;
1077 static tree first_len_val; 
1078 static bool typespec_chararray_ctor;
1079
1080 static void
1081 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1082                               tree offset, gfc_se * se, gfc_expr * expr)
1083 {
1084   tree tmp;
1085
1086   gfc_conv_expr (se, expr);
1087
1088   /* Store the value.  */
1089   tmp = build_fold_indirect_ref_loc (input_location,
1090                                  gfc_conv_descriptor_data_get (desc));
1091   tmp = gfc_build_array_ref (tmp, offset, NULL);
1092
1093   if (expr->ts.type == BT_CHARACTER)
1094     {
1095       int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1096       tree esize;
1097
1098       esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1099       esize = fold_convert (gfc_charlen_type_node, esize);
1100       esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1101                            build_int_cst (gfc_charlen_type_node,
1102                                           gfc_character_kinds[i].bit_size / 8));
1103
1104       gfc_conv_string_parameter (se);
1105       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1106         {
1107           /* The temporary is an array of pointers.  */
1108           se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1109           gfc_add_modify (&se->pre, tmp, se->expr);
1110         }
1111       else
1112         {
1113           /* The temporary is an array of string values.  */
1114           tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1115           /* We know the temporary and the value will be the same length,
1116              so can use memcpy.  */
1117           gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1118                                  se->string_length, se->expr, expr->ts.kind);
1119         }
1120       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1121         {
1122           if (first_len)
1123             {
1124               gfc_add_modify (&se->pre, first_len_val,
1125                                    se->string_length);
1126               first_len = false;
1127             }
1128           else
1129             {
1130               /* Verify that all constructor elements are of the same
1131                  length.  */
1132               tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1133                                        first_len_val, se->string_length);
1134               gfc_trans_runtime_check
1135                 (true, false, cond, &se->pre, &expr->where,
1136                  "Different CHARACTER lengths (%ld/%ld) in array constructor",
1137                  fold_convert (long_integer_type_node, first_len_val),
1138                  fold_convert (long_integer_type_node, se->string_length));
1139             }
1140         }
1141     }
1142   else
1143     {
1144       /* TODO: Should the frontend already have done this conversion?  */
1145       se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1146       gfc_add_modify (&se->pre, tmp, se->expr);
1147     }
1148
1149   gfc_add_block_to_block (pblock, &se->pre);
1150   gfc_add_block_to_block (pblock, &se->post);
1151 }
1152
1153
1154 /* Add the contents of an array to the constructor.  DYNAMIC is as for
1155    gfc_trans_array_constructor_value.  */
1156
1157 static void
1158 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1159                                       tree type ATTRIBUTE_UNUSED,
1160                                       tree desc, gfc_expr * expr,
1161                                       tree * poffset, tree * offsetvar,
1162                                       bool dynamic)
1163 {
1164   gfc_se se;
1165   gfc_ss *ss;
1166   gfc_loopinfo loop;
1167   stmtblock_t body;
1168   tree tmp;
1169   tree size;
1170   int n;
1171
1172   /* We need this to be a variable so we can increment it.  */
1173   gfc_put_offset_into_var (pblock, poffset, offsetvar);
1174
1175   gfc_init_se (&se, NULL);
1176
1177   /* Walk the array expression.  */
1178   ss = gfc_walk_expr (expr);
1179   gcc_assert (ss != gfc_ss_terminator);
1180
1181   /* Initialize the scalarizer.  */
1182   gfc_init_loopinfo (&loop);
1183   gfc_add_ss_to_loop (&loop, ss);
1184
1185   /* Initialize the loop.  */
1186   gfc_conv_ss_startstride (&loop);
1187   gfc_conv_loop_setup (&loop, &expr->where);
1188
1189   /* Make sure the constructed array has room for the new data.  */
1190   if (dynamic)
1191     {
1192       /* Set SIZE to the total number of elements in the subarray.  */
1193       size = gfc_index_one_node;
1194       for (n = 0; n < loop.dimen; n++)
1195         {
1196           tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1197                                          gfc_index_one_node);
1198           size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1199         }
1200
1201       /* Grow the constructed array by SIZE elements.  */
1202       gfc_grow_array (&loop.pre, desc, size);
1203     }
1204
1205   /* Make the loop body.  */
1206   gfc_mark_ss_chain_used (ss, 1);
1207   gfc_start_scalarized_body (&loop, &body);
1208   gfc_copy_loopinfo_to_se (&se, &loop);
1209   se.ss = ss;
1210
1211   gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1212   gcc_assert (se.ss == gfc_ss_terminator);
1213
1214   /* Increment the offset.  */
1215   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1216                      *poffset, gfc_index_one_node);
1217   gfc_add_modify (&body, *poffset, tmp);
1218
1219   /* Finish the loop.  */
1220   gfc_trans_scalarizing_loops (&loop, &body);
1221   gfc_add_block_to_block (&loop.pre, &loop.post);
1222   tmp = gfc_finish_block (&loop.pre);
1223   gfc_add_expr_to_block (pblock, tmp);
1224
1225   gfc_cleanup_loop (&loop);
1226 }
1227
1228
1229 /* Assign the values to the elements of an array constructor.  DYNAMIC
1230    is true if descriptor DESC only contains enough data for the static
1231    size calculated by gfc_get_array_constructor_size.  When true, memory
1232    for the dynamic parts must be allocated using realloc.  */
1233
1234 static void
1235 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1236                                    tree desc, gfc_constructor_base base,
1237                                    tree * poffset, tree * offsetvar,
1238                                    bool dynamic)
1239 {
1240   tree tmp;
1241   stmtblock_t body;
1242   gfc_se se;
1243   mpz_t size;
1244   gfc_constructor *c;
1245
1246   tree shadow_loopvar = NULL_TREE;
1247   gfc_saved_var saved_loopvar;
1248
1249   mpz_init (size);
1250   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1251     {
1252       /* If this is an iterator or an array, the offset must be a variable.  */
1253       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1254         gfc_put_offset_into_var (pblock, poffset, offsetvar);
1255
1256       /* Shadowing the iterator avoids changing its value and saves us from
1257          keeping track of it. Further, it makes sure that there's always a
1258          backend-decl for the symbol, even if there wasn't one before,
1259          e.g. in the case of an iterator that appears in a specification
1260          expression in an interface mapping.  */
1261       if (c->iterator)
1262         {
1263           gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1264           tree type = gfc_typenode_for_spec (&sym->ts);
1265
1266           shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1267           gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1268         }
1269
1270       gfc_start_block (&body);
1271
1272       if (c->expr->expr_type == EXPR_ARRAY)
1273         {
1274           /* Array constructors can be nested.  */
1275           gfc_trans_array_constructor_value (&body, type, desc,
1276                                              c->expr->value.constructor,
1277                                              poffset, offsetvar, dynamic);
1278         }
1279       else if (c->expr->rank > 0)
1280         {
1281           gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1282                                                 poffset, offsetvar, dynamic);
1283         }
1284       else
1285         {
1286           /* This code really upsets the gimplifier so don't bother for now.  */
1287           gfc_constructor *p;
1288           HOST_WIDE_INT n;
1289           HOST_WIDE_INT size;
1290
1291           p = c;
1292           n = 0;
1293           while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1294             {
1295               p = gfc_constructor_next (p);
1296               n++;
1297             }
1298           if (n < 4)
1299             {
1300               /* Scalar values.  */
1301               gfc_init_se (&se, NULL);
1302               gfc_trans_array_ctor_element (&body, desc, *poffset,
1303                                             &se, c->expr);
1304
1305               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1306                                       *poffset, gfc_index_one_node);
1307             }
1308           else
1309             {
1310               /* Collect multiple scalar constants into a constructor.  */
1311               tree list;
1312               tree init;
1313               tree bound;
1314               tree tmptype;
1315               HOST_WIDE_INT idx = 0;
1316
1317               p = c;
1318               list = NULL_TREE;
1319               /* Count the number of consecutive scalar constants.  */
1320               while (p && !(p->iterator
1321                             || p->expr->expr_type != EXPR_CONSTANT))
1322                 {
1323                   gfc_init_se (&se, NULL);
1324                   gfc_conv_constant (&se, p->expr);
1325
1326                   if (c->expr->ts.type != BT_CHARACTER)
1327                     se.expr = fold_convert (type, se.expr);
1328                   /* For constant character array constructors we build
1329                      an array of pointers.  */
1330                   else if (POINTER_TYPE_P (type))
1331                     se.expr = gfc_build_addr_expr
1332                                 (gfc_get_pchar_type (p->expr->ts.kind),
1333                                  se.expr);
1334
1335                   list = tree_cons (build_int_cst (gfc_array_index_type,
1336                                                    idx++), se.expr, list);
1337                   c = p;
1338                   p = gfc_constructor_next (p);
1339                 }
1340
1341               bound = build_int_cst (NULL_TREE, n - 1);
1342               /* Create an array type to hold them.  */
1343               tmptype = build_range_type (gfc_array_index_type,
1344                                           gfc_index_zero_node, bound);
1345               tmptype = build_array_type (type, tmptype);
1346
1347               init = build_constructor_from_list (tmptype, nreverse (list));
1348               TREE_CONSTANT (init) = 1;
1349               TREE_STATIC (init) = 1;
1350               /* Create a static variable to hold the data.  */
1351               tmp = gfc_create_var (tmptype, "data");
1352               TREE_STATIC (tmp) = 1;
1353               TREE_CONSTANT (tmp) = 1;
1354               TREE_READONLY (tmp) = 1;
1355               DECL_INITIAL (tmp) = init;
1356               init = tmp;
1357
1358               /* Use BUILTIN_MEMCPY to assign the values.  */
1359               tmp = gfc_conv_descriptor_data_get (desc);
1360               tmp = build_fold_indirect_ref_loc (input_location,
1361                                              tmp);
1362               tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1363               tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1364               init = gfc_build_addr_expr (NULL_TREE, init);
1365
1366               size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1367               bound = build_int_cst (NULL_TREE, n * size);
1368               tmp = build_call_expr_loc (input_location,
1369                                      built_in_decls[BUILT_IN_MEMCPY], 3,
1370                                      tmp, init, bound);
1371               gfc_add_expr_to_block (&body, tmp);
1372
1373               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1374                                       *poffset,
1375                                       build_int_cst (gfc_array_index_type, n));
1376             }
1377           if (!INTEGER_CST_P (*poffset))
1378             {
1379               gfc_add_modify (&body, *offsetvar, *poffset);
1380               *poffset = *offsetvar;
1381             }
1382         }
1383
1384       /* The frontend should already have done any expansions
1385          at compile-time.  */
1386       if (!c->iterator)
1387         {
1388           /* Pass the code as is.  */
1389           tmp = gfc_finish_block (&body);
1390           gfc_add_expr_to_block (pblock, tmp);
1391         }
1392       else
1393         {
1394           /* Build the implied do-loop.  */
1395           stmtblock_t implied_do_block;
1396           tree cond;
1397           tree end;
1398           tree step;
1399           tree exit_label;
1400           tree loopbody;
1401           tree tmp2;
1402
1403           loopbody = gfc_finish_block (&body);
1404
1405           /* Create a new block that holds the implied-do loop. A temporary
1406              loop-variable is used.  */
1407           gfc_start_block(&implied_do_block);
1408
1409           /* Initialize the loop.  */
1410           gfc_init_se (&se, NULL);
1411           gfc_conv_expr_val (&se, c->iterator->start);
1412           gfc_add_block_to_block (&implied_do_block, &se.pre);
1413           gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1414
1415           gfc_init_se (&se, NULL);
1416           gfc_conv_expr_val (&se, c->iterator->end);
1417           gfc_add_block_to_block (&implied_do_block, &se.pre);
1418           end = gfc_evaluate_now (se.expr, &implied_do_block);
1419
1420           gfc_init_se (&se, NULL);
1421           gfc_conv_expr_val (&se, c->iterator->step);
1422           gfc_add_block_to_block (&implied_do_block, &se.pre);
1423           step = gfc_evaluate_now (se.expr, &implied_do_block);
1424
1425           /* If this array expands dynamically, and the number of iterations
1426              is not constant, we won't have allocated space for the static
1427              part of C->EXPR's size.  Do that now.  */
1428           if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1429             {
1430               /* Get the number of iterations.  */
1431               tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1432
1433               /* Get the static part of C->EXPR's size.  */
1434               gfc_get_array_constructor_element_size (&size, c->expr);
1435               tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1436
1437               /* Grow the array by TMP * TMP2 elements.  */
1438               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1439               gfc_grow_array (&implied_do_block, desc, tmp);
1440             }
1441
1442           /* Generate the loop body.  */
1443           exit_label = gfc_build_label_decl (NULL_TREE);
1444           gfc_start_block (&body);
1445
1446           /* Generate the exit condition.  Depending on the sign of
1447              the step variable we have to generate the correct
1448              comparison.  */
1449           tmp = fold_build2 (GT_EXPR, boolean_type_node, step, 
1450                              build_int_cst (TREE_TYPE (step), 0));
1451           cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1452                               fold_build2 (GT_EXPR, boolean_type_node,
1453                                            shadow_loopvar, end),
1454                               fold_build2 (LT_EXPR, boolean_type_node,
1455                                            shadow_loopvar, end));
1456           tmp = build1_v (GOTO_EXPR, exit_label);
1457           TREE_USED (exit_label) = 1;
1458           tmp = build3_v (COND_EXPR, cond, tmp,
1459                           build_empty_stmt (input_location));
1460           gfc_add_expr_to_block (&body, tmp);
1461
1462           /* The main loop body.  */
1463           gfc_add_expr_to_block (&body, loopbody);
1464
1465           /* Increase loop variable by step.  */
1466           tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1467           gfc_add_modify (&body, shadow_loopvar, tmp);
1468
1469           /* Finish the loop.  */
1470           tmp = gfc_finish_block (&body);
1471           tmp = build1_v (LOOP_EXPR, tmp);
1472           gfc_add_expr_to_block (&implied_do_block, tmp);
1473
1474           /* Add the exit label.  */
1475           tmp = build1_v (LABEL_EXPR, exit_label);
1476           gfc_add_expr_to_block (&implied_do_block, tmp);
1477
1478           /* Finishe the implied-do loop.  */
1479           tmp = gfc_finish_block(&implied_do_block);
1480           gfc_add_expr_to_block(pblock, tmp);
1481
1482           gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1483         }
1484     }
1485   mpz_clear (size);
1486 }
1487
1488
1489 /* Figure out the string length of a variable reference expression.
1490    Used by get_array_ctor_strlen.  */
1491
1492 static void
1493 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1494 {
1495   gfc_ref *ref;
1496   gfc_typespec *ts;
1497   mpz_t char_len;
1498
1499   /* Don't bother if we already know the length is a constant.  */
1500   if (*len && INTEGER_CST_P (*len))
1501     return;
1502
1503   ts = &expr->symtree->n.sym->ts;
1504   for (ref = expr->ref; ref; ref = ref->next)
1505     {
1506       switch (ref->type)
1507         {
1508         case REF_ARRAY:
1509           /* Array references don't change the string length.  */
1510           break;
1511
1512         case REF_COMPONENT:
1513           /* Use the length of the component.  */
1514           ts = &ref->u.c.component->ts;
1515           break;
1516
1517         case REF_SUBSTRING:
1518           if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1519               || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1520             break;
1521           mpz_init_set_ui (char_len, 1);
1522           mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1523           mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1524           *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1525           *len = convert (gfc_charlen_type_node, *len);
1526           mpz_clear (char_len);
1527           return;
1528
1529         default:
1530           /* TODO: Substrings are tricky because we can't evaluate the
1531              expression more than once.  For now we just give up, and hope
1532              we can figure it out elsewhere.  */
1533           return;
1534         }
1535     }
1536
1537   *len = ts->u.cl->backend_decl;
1538 }
1539
1540
1541 /* A catch-all to obtain the string length for anything that is not a
1542    constant, array or variable.  */
1543 static void
1544 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1545 {
1546   gfc_se se;
1547   gfc_ss *ss;
1548
1549   /* Don't bother if we already know the length is a constant.  */
1550   if (*len && INTEGER_CST_P (*len))
1551     return;
1552
1553   if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1554         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1555     {
1556       /* This is easy.  */
1557       gfc_conv_const_charlen (e->ts.u.cl);
1558       *len = e->ts.u.cl->backend_decl;
1559     }
1560   else
1561     {
1562       /* Otherwise, be brutal even if inefficient.  */
1563       ss = gfc_walk_expr (e);
1564       gfc_init_se (&se, NULL);
1565
1566       /* No function call, in case of side effects.  */
1567       se.no_function_call = 1;
1568       if (ss == gfc_ss_terminator)
1569         gfc_conv_expr (&se, e);
1570       else
1571         gfc_conv_expr_descriptor (&se, e, ss);
1572
1573       /* Fix the value.  */
1574       *len = gfc_evaluate_now (se.string_length, &se.pre);
1575
1576       gfc_add_block_to_block (block, &se.pre);
1577       gfc_add_block_to_block (block, &se.post);
1578
1579       e->ts.u.cl->backend_decl = *len;
1580     }
1581 }
1582
1583
1584 /* Figure out the string length of a character array constructor.
1585    If len is NULL, don't calculate the length; this happens for recursive calls
1586    when a sub-array-constructor is an element but not at the first position,
1587    so when we're not interested in the length.
1588    Returns TRUE if all elements are character constants.  */
1589
1590 bool
1591 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1592 {
1593   gfc_constructor *c;
1594   bool is_const;
1595
1596   is_const = TRUE;
1597
1598   if (gfc_constructor_first (base) == NULL)
1599     {
1600       if (len)
1601         *len = build_int_cstu (gfc_charlen_type_node, 0);
1602       return is_const;
1603     }
1604
1605   /* Loop over all constructor elements to find out is_const, but in len we
1606      want to store the length of the first, not the last, element.  We can
1607      of course exit the loop as soon as is_const is found to be false.  */
1608   for (c = gfc_constructor_first (base);
1609        c && is_const; c = gfc_constructor_next (c))
1610     {
1611       switch (c->expr->expr_type)
1612         {
1613         case EXPR_CONSTANT:
1614           if (len && !(*len && INTEGER_CST_P (*len)))
1615             *len = build_int_cstu (gfc_charlen_type_node,
1616                                    c->expr->value.character.length);
1617           break;
1618
1619         case EXPR_ARRAY:
1620           if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1621             is_const = false;
1622           break;
1623
1624         case EXPR_VARIABLE:
1625           is_const = false;
1626           if (len)
1627             get_array_ctor_var_strlen (c->expr, len);
1628           break;
1629
1630         default:
1631           is_const = false;
1632           if (len)
1633             get_array_ctor_all_strlen (block, c->expr, len);
1634           break;
1635         }
1636
1637       /* After the first iteration, we don't want the length modified.  */
1638       len = NULL;
1639     }
1640
1641   return is_const;
1642 }
1643
1644 /* Check whether the array constructor C consists entirely of constant
1645    elements, and if so returns the number of those elements, otherwise
1646    return zero.  Note, an empty or NULL array constructor returns zero.  */
1647
1648 unsigned HOST_WIDE_INT
1649 gfc_constant_array_constructor_p (gfc_constructor_base base)
1650 {
1651   unsigned HOST_WIDE_INT nelem = 0;
1652
1653   gfc_constructor *c = gfc_constructor_first (base);
1654   while (c)
1655     {
1656       if (c->iterator
1657           || c->expr->rank > 0
1658           || c->expr->expr_type != EXPR_CONSTANT)
1659         return 0;
1660       c = gfc_constructor_next (c);
1661       nelem++;
1662     }
1663   return nelem;
1664 }
1665
1666
1667 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1668    and the tree type of it's elements, TYPE, return a static constant
1669    variable that is compile-time initialized.  */
1670
1671 tree
1672 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1673 {
1674   tree tmptype, list, init, tmp;
1675   HOST_WIDE_INT nelem;
1676   gfc_constructor *c;
1677   gfc_array_spec as;
1678   gfc_se se;
1679   int i;
1680
1681   /* First traverse the constructor list, converting the constants
1682      to tree to build an initializer.  */
1683   nelem = 0;
1684   list = NULL_TREE;
1685   c = gfc_constructor_first (expr->value.constructor);
1686   while (c)
1687     {
1688       gfc_init_se (&se, NULL);
1689       gfc_conv_constant (&se, c->expr);
1690       if (c->expr->ts.type != BT_CHARACTER)
1691         se.expr = fold_convert (type, se.expr);
1692       else if (POINTER_TYPE_P (type))
1693         se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1694                                        se.expr);
1695       list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1696                         se.expr, list);
1697       c = gfc_constructor_next (c);
1698       nelem++;
1699     }
1700
1701   /* Next determine the tree type for the array.  We use the gfortran
1702      front-end's gfc_get_nodesc_array_type in order to create a suitable
1703      GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */
1704
1705   memset (&as, 0, sizeof (gfc_array_spec));
1706
1707   as.rank = expr->rank;
1708   as.type = AS_EXPLICIT;
1709   if (!expr->shape)
1710     {
1711       as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1712       as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
1713                                       NULL, nelem - 1);
1714     }
1715   else
1716     for (i = 0; i < expr->rank; i++)
1717       {
1718         int tmp = (int) mpz_get_si (expr->shape[i]);
1719         as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
1720         as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
1721                                         NULL, tmp - 1);
1722       }
1723
1724   tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1725
1726   init = build_constructor_from_list (tmptype, nreverse (list));
1727
1728   TREE_CONSTANT (init) = 1;
1729   TREE_STATIC (init) = 1;
1730
1731   tmp = gfc_create_var (tmptype, "A");
1732   TREE_STATIC (tmp) = 1;
1733   TREE_CONSTANT (tmp) = 1;
1734   TREE_READONLY (tmp) = 1;
1735   DECL_INITIAL (tmp) = init;
1736
1737   return tmp;
1738 }
1739
1740
1741 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1742    This mostly initializes the scalarizer state info structure with the
1743    appropriate values to directly use the array created by the function
1744    gfc_build_constant_array_constructor.  */
1745
1746 static void
1747 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1748                                       gfc_ss * ss, tree type)
1749 {
1750   gfc_ss_info *info;
1751   tree tmp;
1752   int i;
1753
1754   tmp = gfc_build_constant_array_constructor (ss->expr, type);
1755
1756   info = &ss->data.info;
1757
1758   info->descriptor = tmp;
1759   info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1760   info->offset = gfc_index_zero_node;
1761
1762   for (i = 0; i < info->dimen; i++)
1763     {
1764       info->delta[i] = gfc_index_zero_node;
1765       info->start[i] = gfc_index_zero_node;
1766       info->end[i] = gfc_index_zero_node;
1767       info->stride[i] = gfc_index_one_node;
1768       info->dim[i] = i;
1769     }
1770
1771   if (info->dimen > loop->temp_dim)
1772     loop->temp_dim = info->dimen;
1773 }
1774
1775 /* Helper routine of gfc_trans_array_constructor to determine if the
1776    bounds of the loop specified by LOOP are constant and simple enough
1777    to use with gfc_trans_constant_array_constructor.  Returns the
1778    iteration count of the loop if suitable, and NULL_TREE otherwise.  */
1779
1780 static tree
1781 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1782 {
1783   tree size = gfc_index_one_node;
1784   tree tmp;
1785   int i;
1786
1787   for (i = 0; i < loop->dimen; i++)
1788     {
1789       /* If the bounds aren't constant, return NULL_TREE.  */
1790       if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1791         return NULL_TREE;
1792       if (!integer_zerop (loop->from[i]))
1793         {
1794           /* Only allow nonzero "from" in one-dimensional arrays.  */
1795           if (loop->dimen != 1)
1796             return NULL_TREE;
1797           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1798                              loop->to[i], loop->from[i]);
1799         }
1800       else
1801         tmp = loop->to[i];
1802       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1803                          tmp, gfc_index_one_node);
1804       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1805     }
1806
1807   return size;
1808 }
1809
1810
1811 /* Array constructors are handled by constructing a temporary, then using that
1812    within the scalarization loop.  This is not optimal, but seems by far the
1813    simplest method.  */
1814
1815 static void
1816 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1817 {
1818   gfc_constructor_base c;
1819   tree offset;
1820   tree offsetvar;
1821   tree desc;
1822   tree type;
1823   bool dynamic;
1824   bool old_first_len, old_typespec_chararray_ctor;
1825   tree old_first_len_val;
1826
1827   /* Save the old values for nested checking.  */
1828   old_first_len = first_len;
1829   old_first_len_val = first_len_val;
1830   old_typespec_chararray_ctor = typespec_chararray_ctor;
1831
1832   /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1833      typespec was given for the array constructor.  */
1834   typespec_chararray_ctor = (ss->expr->ts.u.cl
1835                              && ss->expr->ts.u.cl->length_from_typespec);
1836
1837   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1838       && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1839     {  
1840       first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1841       first_len = true;
1842     }
1843
1844   ss->data.info.dimen = loop->dimen;
1845
1846   c = ss->expr->value.constructor;
1847   if (ss->expr->ts.type == BT_CHARACTER)
1848     {
1849       bool const_string;
1850       
1851       /* get_array_ctor_strlen walks the elements of the constructor, if a
1852          typespec was given, we already know the string length and want the one
1853          specified there.  */
1854       if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1855           && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1856         {
1857           gfc_se length_se;
1858
1859           const_string = false;
1860           gfc_init_se (&length_se, NULL);
1861           gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1862                               gfc_charlen_type_node);
1863           ss->string_length = length_se.expr;
1864           gfc_add_block_to_block (&loop->pre, &length_se.pre);
1865           gfc_add_block_to_block (&loop->post, &length_se.post);
1866         }
1867       else
1868         const_string = get_array_ctor_strlen (&loop->pre, c,
1869                                               &ss->string_length);
1870
1871       /* Complex character array constructors should have been taken care of
1872          and not end up here.  */
1873       gcc_assert (ss->string_length);
1874
1875       ss->expr->ts.u.cl->backend_decl = ss->string_length;
1876
1877       type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1878       if (const_string)
1879         type = build_pointer_type (type);
1880     }
1881   else
1882     type = gfc_typenode_for_spec (&ss->expr->ts);
1883
1884   /* See if the constructor determines the loop bounds.  */
1885   dynamic = false;
1886
1887   if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1888     {
1889       /* We have a multidimensional parameter.  */
1890       int n;
1891       for (n = 0; n < ss->expr->rank; n++)
1892       {
1893         loop->from[n] = gfc_index_zero_node;
1894         loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1895                                             gfc_index_integer_kind);
1896         loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1897                                    loop->to[n], gfc_index_one_node);
1898       }
1899     }
1900
1901   if (loop->to[0] == NULL_TREE)
1902     {
1903       mpz_t size;
1904
1905       /* We should have a 1-dimensional, zero-based loop.  */
1906       gcc_assert (loop->dimen == 1);
1907       gcc_assert (integer_zerop (loop->from[0]));
1908
1909       /* Split the constructor size into a static part and a dynamic part.
1910          Allocate the static size up-front and record whether the dynamic
1911          size might be nonzero.  */
1912       mpz_init (size);
1913       dynamic = gfc_get_array_constructor_size (&size, c);
1914       mpz_sub_ui (size, size, 1);
1915       loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1916       mpz_clear (size);
1917     }
1918
1919   /* Special case constant array constructors.  */
1920   if (!dynamic)
1921     {
1922       unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1923       if (nelem > 0)
1924         {
1925           tree size = constant_array_constructor_loop_size (loop);
1926           if (size && compare_tree_int (size, nelem) == 0)
1927             {
1928               gfc_trans_constant_array_constructor (loop, ss, type);
1929               goto finish;
1930             }
1931         }
1932     }
1933
1934   gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1935                                type, NULL_TREE, dynamic, true, false, where);
1936
1937   desc = ss->data.info.descriptor;
1938   offset = gfc_index_zero_node;
1939   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1940   TREE_NO_WARNING (offsetvar) = 1;
1941   TREE_USED (offsetvar) = 0;
1942   gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1943                                      &offset, &offsetvar, dynamic);
1944
1945   /* If the array grows dynamically, the upper bound of the loop variable
1946      is determined by the array's final upper bound.  */
1947   if (dynamic)
1948     loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1949
1950   if (TREE_USED (offsetvar))
1951     pushdecl (offsetvar);
1952   else
1953     gcc_assert (INTEGER_CST_P (offset));
1954 #if 0
1955   /* Disable bound checking for now because it's probably broken.  */
1956   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1957     {
1958       gcc_unreachable ();
1959     }
1960 #endif
1961
1962 finish:
1963   /* Restore old values of globals.  */
1964   first_len = old_first_len;
1965   first_len_val = old_first_len_val;
1966   typespec_chararray_ctor = old_typespec_chararray_ctor;
1967 }
1968
1969
1970 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1971    called after evaluating all of INFO's vector dimensions.  Go through
1972    each such vector dimension and see if we can now fill in any missing
1973    loop bounds.  */
1974
1975 static void
1976 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1977 {
1978   gfc_se se;
1979   tree tmp;
1980   tree desc;
1981   tree zero;
1982   int n;
1983   int dim;
1984
1985   for (n = 0; n < loop->dimen; n++)
1986     {
1987       dim = info->dim[n];
1988       if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1989           && loop->to[n] == NULL)
1990         {
1991           /* Loop variable N indexes vector dimension DIM, and we don't
1992              yet know the upper bound of loop variable N.  Set it to the
1993              difference between the vector's upper and lower bounds.  */
1994           gcc_assert (loop->from[n] == gfc_index_zero_node);
1995           gcc_assert (info->subscript[dim]
1996                       && info->subscript[dim]->type == GFC_SS_VECTOR);
1997
1998           gfc_init_se (&se, NULL);
1999           desc = info->subscript[dim]->data.info.descriptor;
2000           zero = gfc_rank_cst[0];
2001           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2002                              gfc_conv_descriptor_ubound_get (desc, zero),
2003                              gfc_conv_descriptor_lbound_get (desc, zero));
2004           tmp = gfc_evaluate_now (tmp, &loop->pre);
2005           loop->to[n] = tmp;
2006         }
2007     }
2008 }
2009
2010
2011 /* Add the pre and post chains for all the scalar expressions in a SS chain
2012    to loop.  This is called after the loop parameters have been calculated,
2013    but before the actual scalarizing loops.  */
2014
2015 static void
2016 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2017                       locus * where)
2018 {
2019   gfc_se se;
2020   int n;
2021
2022   /* TODO: This can generate bad code if there are ordering dependencies,
2023      e.g., a callee allocated function and an unknown size constructor.  */
2024   gcc_assert (ss != NULL);
2025
2026   for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2027     {
2028       gcc_assert (ss);
2029
2030       switch (ss->type)
2031         {
2032         case GFC_SS_SCALAR:
2033           /* Scalar expression.  Evaluate this now.  This includes elemental
2034              dimension indices, but not array section bounds.  */
2035           gfc_init_se (&se, NULL);
2036           gfc_conv_expr (&se, ss->expr);
2037           gfc_add_block_to_block (&loop->pre, &se.pre);
2038
2039           if (ss->expr->ts.type != BT_CHARACTER)
2040             {
2041               /* Move the evaluation of scalar expressions outside the
2042                  scalarization loop, except for WHERE assignments.  */
2043               if (subscript)
2044                 se.expr = convert(gfc_array_index_type, se.expr);
2045               if (!ss->where)
2046                 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2047               gfc_add_block_to_block (&loop->pre, &se.post);
2048             }
2049           else
2050             gfc_add_block_to_block (&loop->post, &se.post);
2051
2052           ss->data.scalar.expr = se.expr;
2053           ss->string_length = se.string_length;
2054           break;
2055
2056         case GFC_SS_REFERENCE:
2057           /* Scalar reference.  Evaluate this now.  */
2058           gfc_init_se (&se, NULL);
2059           gfc_conv_expr_reference (&se, ss->expr);
2060           gfc_add_block_to_block (&loop->pre, &se.pre);
2061           gfc_add_block_to_block (&loop->post, &se.post);
2062
2063           ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2064           ss->string_length = se.string_length;
2065           break;
2066
2067         case GFC_SS_SECTION:
2068           /* Add the expressions for scalar and vector subscripts.  */
2069           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2070             if (ss->data.info.subscript[n])
2071               gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2072                                     where);
2073
2074           gfc_set_vector_loop_bounds (loop, &ss->data.info);
2075           break;
2076
2077         case GFC_SS_VECTOR:
2078           /* Get the vector's descriptor and store it in SS.  */
2079           gfc_init_se (&se, NULL);
2080           gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2081           gfc_add_block_to_block (&loop->pre, &se.pre);
2082           gfc_add_block_to_block (&loop->post, &se.post);
2083           ss->data.info.descriptor = se.expr;
2084           break;
2085
2086         case GFC_SS_INTRINSIC:
2087           gfc_add_intrinsic_ss_code (loop, ss);
2088           break;
2089
2090         case GFC_SS_FUNCTION:
2091           /* Array function return value.  We call the function and save its
2092              result in a temporary for use inside the loop.  */
2093           gfc_init_se (&se, NULL);
2094           se.loop = loop;
2095           se.ss = ss;
2096           gfc_conv_expr (&se, ss->expr);
2097           gfc_add_block_to_block (&loop->pre, &se.pre);
2098           gfc_add_block_to_block (&loop->post, &se.post);
2099           ss->string_length = se.string_length;
2100           break;
2101
2102         case GFC_SS_CONSTRUCTOR:
2103           if (ss->expr->ts.type == BT_CHARACTER
2104                 && ss->string_length == NULL
2105                 && ss->expr->ts.u.cl
2106                 && ss->expr->ts.u.cl->length)
2107             {
2108               gfc_init_se (&se, NULL);
2109               gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2110                                   gfc_charlen_type_node);
2111               ss->string_length = se.expr;
2112               gfc_add_block_to_block (&loop->pre, &se.pre);
2113               gfc_add_block_to_block (&loop->post, &se.post);
2114             }
2115           gfc_trans_array_constructor (loop, ss, where);
2116           break;
2117
2118         case GFC_SS_TEMP:
2119         case GFC_SS_COMPONENT:
2120           /* Do nothing.  These are handled elsewhere.  */
2121           break;
2122
2123         default:
2124           gcc_unreachable ();
2125         }
2126     }
2127 }
2128
2129
2130 /* Translate expressions for the descriptor and data pointer of a SS.  */
2131 /*GCC ARRAYS*/
2132
2133 static void
2134 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2135 {
2136   gfc_se se;
2137   tree tmp;
2138
2139   /* Get the descriptor for the array to be scalarized.  */
2140   gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2141   gfc_init_se (&se, NULL);
2142   se.descriptor_only = 1;
2143   gfc_conv_expr_lhs (&se, ss->expr);
2144   gfc_add_block_to_block (block, &se.pre);
2145   ss->data.info.descriptor = se.expr;
2146   ss->string_length = se.string_length;
2147
2148   if (base)
2149     {
2150       /* Also the data pointer.  */
2151       tmp = gfc_conv_array_data (se.expr);
2152       /* If this is a variable or address of a variable we use it directly.
2153          Otherwise we must evaluate it now to avoid breaking dependency
2154          analysis by pulling the expressions for elemental array indices
2155          inside the loop.  */
2156       if (!(DECL_P (tmp)
2157             || (TREE_CODE (tmp) == ADDR_EXPR
2158                 && DECL_P (TREE_OPERAND (tmp, 0)))))
2159         tmp = gfc_evaluate_now (tmp, block);
2160       ss->data.info.data = tmp;
2161
2162       tmp = gfc_conv_array_offset (se.expr);
2163       ss->data.info.offset = gfc_evaluate_now (tmp, block);
2164     }
2165 }
2166
2167
2168 /* Initialize a gfc_loopinfo structure.  */
2169
2170 void
2171 gfc_init_loopinfo (gfc_loopinfo * loop)
2172 {
2173   int n;
2174
2175   memset (loop, 0, sizeof (gfc_loopinfo));
2176   gfc_init_block (&loop->pre);
2177   gfc_init_block (&loop->post);
2178
2179   /* Initially scalarize in order.  */
2180   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2181     loop->order[n] = n;
2182
2183   loop->ss = gfc_ss_terminator;
2184 }
2185
2186
2187 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2188    chain.  */
2189
2190 void
2191 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2192 {
2193   se->loop = loop;
2194 }
2195
2196
2197 /* Return an expression for the data pointer of an array.  */
2198
2199 tree
2200 gfc_conv_array_data (tree descriptor)
2201 {
2202   tree type;
2203
2204   type = TREE_TYPE (descriptor);
2205   if (GFC_ARRAY_TYPE_P (type))
2206     {
2207       if (TREE_CODE (type) == POINTER_TYPE)
2208         return descriptor;
2209       else
2210         {
2211           /* Descriptorless arrays.  */
2212           return gfc_build_addr_expr (NULL_TREE, descriptor);
2213         }
2214     }
2215   else
2216     return gfc_conv_descriptor_data_get (descriptor);
2217 }
2218
2219
2220 /* Return an expression for the base offset of an array.  */
2221
2222 tree
2223 gfc_conv_array_offset (tree descriptor)
2224 {
2225   tree type;
2226
2227   type = TREE_TYPE (descriptor);
2228   if (GFC_ARRAY_TYPE_P (type))
2229     return GFC_TYPE_ARRAY_OFFSET (type);
2230   else
2231     return gfc_conv_descriptor_offset_get (descriptor);
2232 }
2233
2234
2235 /* Get an expression for the array stride.  */
2236
2237 tree
2238 gfc_conv_array_stride (tree descriptor, int dim)
2239 {
2240   tree tmp;
2241   tree type;
2242
2243   type = TREE_TYPE (descriptor);
2244
2245   /* For descriptorless arrays use the array size.  */
2246   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2247   if (tmp != NULL_TREE)
2248     return tmp;
2249
2250   tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2251   return tmp;
2252 }
2253
2254
2255 /* Like gfc_conv_array_stride, but for the lower bound.  */
2256
2257 tree
2258 gfc_conv_array_lbound (tree descriptor, int dim)
2259 {
2260   tree tmp;
2261   tree type;
2262
2263   type = TREE_TYPE (descriptor);
2264
2265   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2266   if (tmp != NULL_TREE)
2267     return tmp;
2268
2269   tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2270   return tmp;
2271 }
2272
2273
2274 /* Like gfc_conv_array_stride, but for the upper bound.  */
2275
2276 tree
2277 gfc_conv_array_ubound (tree descriptor, int dim)
2278 {
2279   tree tmp;
2280   tree type;
2281
2282   type = TREE_TYPE (descriptor);
2283
2284   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2285   if (tmp != NULL_TREE)
2286     return tmp;
2287
2288   /* This should only ever happen when passing an assumed shape array
2289      as an actual parameter.  The value will never be used.  */
2290   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2291     return gfc_index_zero_node;
2292
2293   tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2294   return tmp;
2295 }
2296
2297
2298 /* Generate code to perform an array index bound check.  */
2299
2300 static tree
2301 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2302                              locus * where, bool check_upper)
2303 {
2304   tree fault;
2305   tree tmp_lo, tmp_up;
2306   char *msg;
2307   const char * name = NULL;
2308
2309   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2310     return index;
2311
2312   index = gfc_evaluate_now (index, &se->pre);
2313
2314   /* We find a name for the error message.  */
2315   if (se->ss)
2316     name = se->ss->expr->symtree->name;
2317
2318   if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2319       && se->loop->ss->expr->symtree)
2320     name = se->loop->ss->expr->symtree->name;
2321
2322   if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2323       && se->loop->ss->loop_chain->expr
2324       && se->loop->ss->loop_chain->expr->symtree)
2325     name = se->loop->ss->loop_chain->expr->symtree->name;
2326
2327   if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2328     {
2329       if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2330           && se->loop->ss->expr->value.function.name)
2331         name = se->loop->ss->expr->value.function.name;
2332       else
2333         if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2334             || se->loop->ss->type == GFC_SS_SCALAR)
2335           name = "unnamed constant";
2336     }
2337
2338   if (descriptor->base.code != COMPONENT_REF)
2339     name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2340
2341   /* If upper bound is present, include both bounds in the error message.  */
2342   if (check_upper)
2343     {
2344       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2345       tmp_up = gfc_conv_array_ubound (descriptor, n);
2346
2347       if (name)
2348         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2349                   "outside of expected range (%%ld:%%ld)", n+1, name);
2350       else
2351         asprintf (&msg, "Index '%%ld' of dimension %d "
2352                   "outside of expected range (%%ld:%%ld)", n+1);
2353
2354       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2355       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2356                                fold_convert (long_integer_type_node, index),
2357                                fold_convert (long_integer_type_node, tmp_lo),
2358                                fold_convert (long_integer_type_node, tmp_up));
2359       fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2360       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2361                                fold_convert (long_integer_type_node, index),
2362                                fold_convert (long_integer_type_node, tmp_lo),
2363                                fold_convert (long_integer_type_node, tmp_up));
2364       gfc_free (msg);
2365     }
2366   else
2367     {
2368       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2369
2370       if (name)
2371         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2372                   "below lower bound of %%ld", n+1, name);
2373       else
2374         asprintf (&msg, "Index '%%ld' of dimension %d "
2375                   "below lower bound of %%ld", n+1);
2376
2377       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2378       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2379                                fold_convert (long_integer_type_node, index),
2380                                fold_convert (long_integer_type_node, tmp_lo));
2381       gfc_free (msg);
2382     }
2383
2384   return index;
2385 }
2386
2387
2388 /* Return the offset for an index.  Performs bound checking for elemental
2389    dimensions.  Single element references are processed separately.  */
2390
2391 static tree
2392 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2393                              gfc_array_ref * ar, tree stride)
2394 {
2395   tree index;
2396   tree desc;
2397   tree data;
2398
2399   /* Get the index into the array for this dimension.  */
2400   if (ar)
2401     {
2402       gcc_assert (ar->type != AR_ELEMENT);
2403       switch (ar->dimen_type[dim])
2404         {
2405         case DIMEN_ELEMENT:
2406           /* Elemental dimension.  */
2407           gcc_assert (info->subscript[dim]
2408                       && info->subscript[dim]->type == GFC_SS_SCALAR);
2409           /* We've already translated this value outside the loop.  */
2410           index = info->subscript[dim]->data.scalar.expr;
2411
2412           index = gfc_trans_array_bound_check (se, info->descriptor,
2413                         index, dim, &ar->where,
2414                         ar->as->type != AS_ASSUMED_SIZE
2415                         || dim < ar->dimen - 1);
2416           break;
2417
2418         case DIMEN_VECTOR:
2419           gcc_assert (info && se->loop);
2420           gcc_assert (info->subscript[dim]
2421                       && info->subscript[dim]->type == GFC_SS_VECTOR);
2422           desc = info->subscript[dim]->data.info.descriptor;
2423
2424           /* Get a zero-based index into the vector.  */
2425           index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2426                                se->loop->loopvar[i], se->loop->from[i]);
2427
2428           /* Multiply the index by the stride.  */
2429           index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2430                                index, gfc_conv_array_stride (desc, 0));
2431
2432           /* Read the vector to get an index into info->descriptor.  */
2433           data = build_fold_indirect_ref_loc (input_location,
2434                                           gfc_conv_array_data (desc));
2435           index = gfc_build_array_ref (data, index, NULL);
2436           index = gfc_evaluate_now (index, &se->pre);
2437
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);
3381             }
3382
3383           tmp = gfc_finish_block (&inner);
3384
3385           /* For optional arguments, only check bounds if the argument is
3386              present.  */
3387           if (ss->expr->symtree->n.sym->attr.optional
3388               || ss->expr->symtree->n.sym->attr.not_always_present)
3389             tmp = build3_v (COND_EXPR,
3390                             gfc_conv_expr_present (ss->expr->symtree->n.sym),
3391                             tmp, build_empty_stmt (input_location));
3392
3393           gfc_add_expr_to_block (&block, tmp);
3394
3395         }
3396
3397       tmp = gfc_finish_block (&block);
3398       gfc_add_expr_to_block (&loop->pre, tmp);
3399     }
3400 }
3401
3402
3403 /* Return true if the two SS could be aliased, i.e. both point to the same data
3404    object.  */
3405 /* TODO: resolve aliases based on frontend expressions.  */
3406
3407 static int
3408 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
3409 {
3410   gfc_ref *lref;
3411   gfc_ref *rref;
3412   gfc_symbol *lsym;
3413   gfc_symbol *rsym;
3414
3415   lsym = lss->expr->symtree->n.sym;
3416   rsym = rss->expr->symtree->n.sym;
3417   if (gfc_symbols_could_alias (lsym, rsym))
3418     return 1;
3419
3420   if (rsym->ts.type != BT_DERIVED
3421       && lsym->ts.type != BT_DERIVED)
3422     return 0;
3423
3424   /* For derived types we must check all the component types.  We can ignore
3425      array references as these will have the same base type as the previous
3426      component ref.  */
3427   for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
3428     {
3429       if (lref->type != REF_COMPONENT)
3430         continue;
3431
3432       if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
3433         return 1;
3434
3435       for (rref = rss->expr->ref; rref != rss->data.info.ref;
3436            rref = rref->next)
3437         {
3438           if (rref->type != REF_COMPONENT)
3439             continue;
3440
3441           if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
3442             return 1;
3443         }
3444     }
3445
3446   for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
3447     {
3448       if (rref->type != REF_COMPONENT)
3449         break;
3450
3451       if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
3452         return 1;
3453     }
3454
3455   return 0;
3456 }
3457
3458
3459 /* Resolve array data dependencies.  Creates a temporary if required.  */
3460 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
3461    dependency.c.  */
3462
3463 void
3464 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
3465                                gfc_ss * rss)
3466 {
3467   gfc_ss *ss;
3468   gfc_ref *lref;
3469   gfc_ref *rref;
3470   int nDepend = 0;
3471
3472   loop->temp_ss = NULL;
3473
3474   for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
3475     {
3476       if (ss->type != GFC_SS_SECTION)
3477         continue;
3478
3479       if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
3480         {
3481           if (gfc_could_be_alias (dest, ss)
3482                 || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
3483             {
3484               nDepend = 1;
3485               break;
3486             }
3487         }
3488       else
3489         {
3490           lref = dest->expr->ref;
3491           rref = ss->expr->ref;
3492
3493           nDepend = gfc_dep_resolver (lref, rref);
3494           if (nDepend == 1)
3495             break;
3496 #if 0
3497           /* TODO : loop shifting.  */
3498           if (nDepend == 1)
3499             {
3500               /* Mark the dimensions for LOOP SHIFTING */
3501               for (n = 0; n < loop->dimen; n++)
3502                 {
3503                   int dim = dest->data.info.dim[n];
3504
3505                   if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3506                     depends[n] = 2;
3507                   else if (! gfc_is_same_range (&lref->u.ar,
3508                                                 &rref->u.ar, dim, 0))
3509                     depends[n] = 1;
3510                  }
3511
3512               /* Put all the dimensions with dependencies in the
3513                  innermost loops.  */
3514               dim = 0;
3515               for (n = 0; n < loop->dimen; n++)
3516                 {
3517                   gcc_assert (loop->order[n] == n);
3518                   if (depends[n])
3519                   loop->order[dim++] = n;
3520                 }
3521               for (n = 0; n < loop->dimen; n++)
3522                 {
3523                   if (! depends[n])
3524                   loop->order[dim++] = n;
3525                 }
3526
3527               gcc_assert (dim == loop->dimen);
3528               break;
3529             }
3530 #endif
3531         }
3532     }
3533
3534   if (nDepend == 1)
3535     {
3536       tree base_type = gfc_typenode_for_spec (&dest->expr->ts);
3537       if (GFC_ARRAY_TYPE_P (base_type)
3538           || GFC_DESCRIPTOR_TYPE_P (base_type))
3539         base_type = gfc_get_element_type (base_type);
3540       loop->temp_ss = gfc_get_ss ();
3541       loop->temp_ss->type = GFC_SS_TEMP;
3542       loop->temp_ss->data.temp.type = base_type;
3543       loop->temp_ss->string_length = dest->string_length;
3544       loop->temp_ss->data.temp.dimen = loop->dimen;
3545       loop->temp_ss->next = gfc_ss_terminator;
3546       gfc_add_ss_to_loop (loop, loop->temp_ss);
3547     }
3548   else
3549     loop->temp_ss = NULL;
3550 }
3551
3552
3553 /* Initialize the scalarization loop.  Creates the loop variables.  Determines
3554    the range of the loop variables.  Creates a temporary if required.
3555    Calculates how to transform from loop variables to array indices for each
3556    expression.  Also generates code for scalar expressions which have been
3557    moved outside the loop.  */
3558
3559 void
3560 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
3561 {
3562   int n;
3563   gfc_ss_info *info;
3564   gfc_ss_info *specinfo;
3565   gfc_ss *ss;
3566   tree tmp;
3567   gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
3568   bool dynamic[GFC_MAX_DIMENSIONS];
3569   mpz_t *cshape;
3570   mpz_t i;
3571
3572   mpz_init (i);
3573   for (n = 0; n < loop->dimen; n++)
3574     {
3575       loopspec[n] = NULL;
3576       dynamic[n] = false;
3577       /* We use one SS term, and use that to determine the bounds of the
3578          loop for this dimension.  We try to pick the simplest term.  */
3579       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3580         {
3581           if (ss->shape)
3582             {
3583               /* The frontend has worked out the size for us.  */
3584               if (!loopspec[n] || !loopspec[n]->shape
3585                     || !integer_zerop (loopspec[n]->data.info.start[n]))
3586                 /* Prefer zero-based descriptors if possible.  */
3587                 loopspec[n] = ss;
3588               continue;
3589             }
3590
3591           if (ss->type == GFC_SS_CONSTRUCTOR)
3592             {
3593               gfc_constructor_base base;
3594               /* An unknown size constructor will always be rank one.
3595                  Higher rank constructors will either have known shape,
3596                  or still be wrapped in a call to reshape.  */
3597               gcc_assert (loop->dimen == 1);
3598
3599               /* Always prefer to use the constructor bounds if the size
3600                  can be determined at compile time.  Prefer not to otherwise,
3601                  since the general case involves realloc, and it's better to
3602                  avoid that overhead if possible.  */
3603               base = ss->expr->value.constructor;
3604               dynamic[n] = gfc_get_array_constructor_size (&i, base);
3605               if (!dynamic[n] || !loopspec[n])
3606                 loopspec[n] = ss;
3607               continue;
3608             }
3609
3610           /* TODO: Pick the best bound if we have a choice between a
3611              function and something else.  */
3612           if (ss->type == GFC_SS_FUNCTION)
3613             {
3614               loopspec[n] = ss;
3615               continue;
3616             }
3617
3618           if (ss->type != GFC_SS_SECTION)
3619             continue;
3620
3621           if (loopspec[n])
3622             specinfo = &loopspec[n]->data.info;
3623           else
3624             specinfo = NULL;
3625           info = &ss->data.info;
3626
3627           if (!specinfo)
3628             loopspec[n] = ss;
3629           /* Criteria for choosing a loop specifier (most important first):
3630              doesn't need realloc
3631              stride of one
3632              known stride
3633              known lower bound
3634              known upper bound
3635            */
3636           else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
3637             loopspec[n] = ss;
3638           else if (integer_onep (info->stride[n])
3639                    && !integer_onep (specinfo->stride[n]))
3640             loopspec[n] = ss;
3641           else if (INTEGER_CST_P (info->stride[n])
3642                    && !INTEGER_CST_P (specinfo->stride[n]))
3643             loopspec[n] = ss;
3644           else if (INTEGER_CST_P (info->start[n])
3645                    && !INTEGER_CST_P (specinfo->start[n]))
3646             loopspec[n] = ss;
3647           /* We don't work out the upper bound.
3648              else if (INTEGER_CST_P (info->finish[n])
3649              && ! INTEGER_CST_P (specinfo->finish[n]))
3650              loopspec[n] = ss; */
3651         }
3652
3653       /* We should have found the scalarization loop specifier.  If not,
3654          that's bad news.  */
3655       gcc_assert (loopspec[n]);
3656
3657       info = &loopspec[n]->data.info;
3658
3659       /* Set the extents of this range.  */
3660       cshape = loopspec[n]->shape;
3661       if (cshape && INTEGER_CST_P (info->start[n])
3662           && INTEGER_CST_P (info->stride[n]))
3663         {
3664           loop->from[n] = info->start[n];
3665           mpz_set (i, cshape[n]);
3666           mpz_sub_ui (i, i, 1);
3667           /* To = from + (size - 1) * stride.  */
3668           tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
3669           if (!integer_onep (info->stride[n]))
3670             tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3671                                tmp, info->stride[n]);
3672           loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3673                                      loop->from[n], tmp);
3674         }
3675       else
3676         {
3677           loop->from[n] = info->start[n];
3678           switch (loopspec[n]->type)
3679             {
3680             case GFC_SS_CONSTRUCTOR:
3681               /* The upper bound is calculated when we expand the
3682                  constructor.  */
3683               gcc_assert (loop->to[n] == NULL_TREE);
3684               break;
3685
3686             case GFC_SS_SECTION:
3687               /* Use the end expression if it exists and is not constant,
3688                  so that it is only evaluated once.  */
3689               if (info->end[n] && !INTEGER_CST_P (info->end[n]))
3690                 loop->to[n] = info->end[n];
3691               else
3692                 loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
3693                                                             &loop->pre);
3694               break;
3695
3696             case GFC_SS_FUNCTION:
3697               /* The loop bound will be set when we generate the call.  */
3698               gcc_assert (loop->to[n] == NULL_TREE);
3699               break;
3700
3701             default:
3702               gcc_unreachable ();
3703             }
3704         }
3705
3706       /* Transform everything so we have a simple incrementing variable.  */
3707       if (integer_onep (info->stride[n]))
3708         info->delta[n] = gfc_index_zero_node;
3709       else
3710         {
3711           /* Set the delta for this section.  */
3712           info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
3713           /* Number of iterations is (end - start + step) / step.
3714              with start = 0, this simplifies to
3715              last = end / step;
3716              for (i = 0; i<=last; i++){...};  */
3717           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3718                              loop->to[n], loop->from[n]);
3719           tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, 
3720                              tmp, info->stride[n]);
3721           tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3722                              build_int_cst (gfc_array_index_type, -1));
3723           loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
3724           /* Make the loop variable start at 0.  */
3725           loop->from[n] = gfc_index_zero_node;
3726         }
3727     }
3728
3729   /* Add all the scalar code that can be taken out of the loops.
3730      This may include calculating the loop bounds, so do it before
3731      allocating the temporary.  */
3732   gfc_add_loop_ss_code (loop, loop->ss, false, where);
3733
3734   /* If we want a temporary then create it.  */
3735   if (loop->temp_ss != NULL)
3736     {
3737       gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
3738
3739       /* Make absolutely sure that this is a complete type.  */
3740       if (loop->temp_ss->string_length)
3741         loop->temp_ss->data.temp.type
3742                 = gfc_get_character_type_len_for_eltype
3743                         (TREE_TYPE (loop->temp_ss->data.temp.type),
3744                          loop->temp_ss->string_length);
3745
3746       tmp = loop->temp_ss->data.temp.type;
3747       n = loop->temp_ss->data.temp.dimen;
3748       memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
3749       loop->temp_ss->type = GFC_SS_SECTION;
3750       loop->temp_ss->data.info.dimen = n;
3751       gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
3752                                    &loop->temp_ss->data.info, tmp, NULL_TREE,
3753                                    false, true, false, where);
3754     }
3755
3756   for (n = 0; n < loop->temp_dim; n++)
3757     loopspec[loop->order[n]] = NULL;
3758
3759   mpz_clear (i);
3760
3761   /* For array parameters we don't have loop variables, so don't calculate the
3762      translations.  */
3763   if (loop->array_parameter)
3764     return;
3765
3766   /* Calculate the translation from loop variables to array indices.  */
3767   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3768     {
3769       if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
3770             && ss->type != GFC_SS_CONSTRUCTOR)
3771
3772         continue;
3773
3774       info = &ss->data.info;
3775
3776       for (n = 0; n < info->dimen; n++)
3777         {
3778           /* If we are specifying the range the delta is already set.  */
3779           if (loopspec[n] != ss)
3780             {
3781               /* Calculate the offset relative to the loop variable.
3782                  First multiply by the stride.  */
3783               tmp = loop->from[n];
3784               if (!integer_onep (info->stride[n]))
3785                 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3786                                    tmp, info->stride[n]);
3787
3788               /* Then subtract this from our starting value.  */
3789               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3790                                  info->start[n], tmp);
3791
3792               info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
3793             }
3794         }
3795     }
3796 }
3797
3798
3799 /* Fills in an array descriptor, and returns the size of the array.  The size
3800    will be a simple_val, ie a variable or a constant.  Also calculates the
3801    offset of the base.  Returns the size of the array.
3802    {
3803     stride = 1;
3804     offset = 0;
3805     for (n = 0; n < rank; n++)
3806       {
3807         a.lbound[n] = specified_lower_bound;
3808         offset = offset + a.lbond[n] * stride;
3809         size = 1 - lbound;
3810         a.ubound[n] = specified_upper_bound;
3811         a.stride[n] = stride;
3812         size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
3813         stride = stride * size;
3814       }
3815     return (stride);
3816    }  */
3817 /*GCC ARRAYS*/
3818
3819 static tree
3820 gfc_array_init_size (tree descriptor, int rank, tree * poffset,
3821                      gfc_expr ** lower, gfc_expr ** upper,
3822                      stmtblock_t * pblock)
3823 {
3824   tree type;
3825   tree tmp;
3826   tree size;
3827   tree offset;
3828   tree stride;
3829   tree cond;
3830   tree or_expr;
3831   tree thencase;
3832   tree elsecase;
3833   tree var;
3834   stmtblock_t thenblock;
3835   stmtblock_t elseblock;
3836   gfc_expr *ubound;
3837   gfc_se se;
3838   int n;
3839
3840   type = TREE_TYPE (descriptor);
3841
3842   stride = gfc_index_one_node;
3843   offset = gfc_index_zero_node;
3844
3845   /* Set the dtype.  */
3846   tmp = gfc_conv_descriptor_dtype (descriptor);
3847   gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
3848
3849   or_expr = NULL_TREE;
3850
3851   for (n = 0; n < rank; n++)
3852     {
3853       /* We have 3 possibilities for determining the size of the array:
3854          lower == NULL    => lbound = 1, ubound = upper[n]
3855          upper[n] = NULL  => lbound = 1, ubound = lower[n]
3856          upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
3857       ubound = upper[n];
3858
3859       /* Set lower bound.  */
3860       gfc_init_se (&se, NULL);
3861       if (lower == NULL)
3862         se.expr = gfc_index_one_node;
3863       else
3864         {
3865           gcc_assert (lower[n]);
3866           if (ubound)
3867             {
3868               gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
3869               gfc_add_block_to_block (pblock, &se.pre);
3870             }
3871           else
3872             {
3873               se.expr = gfc_index_one_node;
3874               ubound = lower[n];
3875             }
3876         }
3877       gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
3878                                       se.expr);
3879
3880       /* Work out the offset for this component.  */
3881       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
3882       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
3883
3884       /* Start the calculation for the size of this dimension.  */
3885       size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3886                           gfc_index_one_node, se.expr);
3887
3888       /* Set upper bound.  */
3889       gfc_init_se (&se, NULL);
3890       gcc_assert (ubound);
3891       gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
3892       gfc_add_block_to_block (pblock, &se.pre);
3893
3894       gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
3895
3896       /* Store the stride.  */
3897       gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
3898
3899       /* Calculate the size of this dimension.  */
3900       size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
3901
3902       /* Check whether the size for this dimension is negative.  */
3903       cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3904                           gfc_index_zero_node);
3905       if (n == 0)
3906         or_expr = cond;
3907       else
3908         or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
3909
3910       size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3911                           gfc_index_zero_node, size);
3912
3913       /* Multiply the stride by the number of elements in this dimension.  */
3914       stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
3915       stride = gfc_evaluate_now (stride, pblock);
3916     }
3917
3918   /* The stride is the number of elements in the array, so multiply by the
3919      size of an element to get the total size.  */
3920   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3921   size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
3922                       fold_convert (gfc_array_index_type, tmp));
3923
3924   if (poffset != NULL)
3925     {
3926       offset = gfc_evaluate_now (offset, pblock);
3927       *poffset = offset;
3928     }
3929
3930   if (integer_zerop (or_expr))
3931     return size;
3932   if (integer_onep (or_expr))