OSDN Git Service

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