OSDN Git Service

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