OSDN Git Service

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