OSDN Git Service

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