OSDN Git Service

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