OSDN Git Service

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