OSDN Git Service

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