OSDN Git Service

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