OSDN Git Service

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