OSDN Git Service

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