OSDN Git Service

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