OSDN Git Service

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