OSDN Git Service

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