OSDN Git Service

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