OSDN Git Service

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