OSDN Git Service

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