OSDN Git Service

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