OSDN Git Service

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