OSDN Git Service

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