OSDN Git Service

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