OSDN Git Service

* trans-array.c (constant_array_constructor_loop_size):
[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 * l)
2057 {
2058   gfc_loopinfo *loop;
2059   tree size = gfc_index_one_node;
2060   tree tmp;
2061   int i, total_dim;
2062
2063   total_dim = get_rank (l);
2064
2065   for (loop = l; loop; loop = loop->parent)
2066     {
2067       for (i = 0; i < loop->dimen; i++)
2068         {
2069           /* If the bounds aren't constant, return NULL_TREE.  */
2070           if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2071             return NULL_TREE;
2072           if (!integer_zerop (loop->from[i]))
2073             {
2074               /* Only allow nonzero "from" in one-dimensional arrays.  */
2075               if (total_dim != 1)
2076                 return NULL_TREE;
2077               tmp = fold_build2_loc (input_location, MINUS_EXPR,
2078                                      gfc_array_index_type,
2079                                      loop->to[i], loop->from[i]);
2080             }
2081           else
2082             tmp = loop->to[i];
2083           tmp = fold_build2_loc (input_location, PLUS_EXPR,
2084                                  gfc_array_index_type, tmp, gfc_index_one_node);
2085           size = fold_build2_loc (input_location, MULT_EXPR,
2086                                   gfc_array_index_type, size, tmp);
2087         }
2088     }
2089
2090   return size;
2091 }
2092
2093
2094 static tree *
2095 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2096 {
2097   gfc_ss *ss;
2098   int n;
2099
2100   gcc_assert (array->nested_ss == NULL);
2101
2102   for (ss = array; ss; ss = ss->parent)
2103     for (n = 0; n < ss->loop->dimen; n++)
2104       if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2105         return &(ss->loop->to[n]);
2106
2107   gcc_unreachable ();
2108 }
2109
2110
2111 /* Array constructors are handled by constructing a temporary, then using that
2112    within the scalarization loop.  This is not optimal, but seems by far the
2113    simplest method.  */
2114
2115 static void
2116 trans_array_constructor (gfc_ss * ss, locus * where)
2117 {
2118   gfc_constructor_base c;
2119   tree offset;
2120   tree offsetvar;
2121   tree desc;
2122   tree type;
2123   tree tmp;
2124   tree *loop_ubound0;
2125   bool dynamic;
2126   bool old_first_len, old_typespec_chararray_ctor;
2127   tree old_first_len_val;
2128   gfc_loopinfo *loop;
2129   gfc_ss_info *ss_info;
2130   gfc_expr *expr;
2131   gfc_ss *s;
2132
2133   /* Save the old values for nested checking.  */
2134   old_first_len = first_len;
2135   old_first_len_val = first_len_val;
2136   old_typespec_chararray_ctor = typespec_chararray_ctor;
2137
2138   loop = ss->loop;
2139   ss_info = ss->info;
2140   expr = ss_info->expr;
2141
2142   /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2143      typespec was given for the array constructor.  */
2144   typespec_chararray_ctor = (expr->ts.u.cl
2145                              && expr->ts.u.cl->length_from_typespec);
2146
2147   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2148       && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2149     {  
2150       first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2151       first_len = true;
2152     }
2153
2154   gcc_assert (ss->dimen == ss->loop->dimen);
2155
2156   c = expr->value.constructor;
2157   if (expr->ts.type == BT_CHARACTER)
2158     {
2159       bool const_string;
2160       
2161       /* get_array_ctor_strlen walks the elements of the constructor, if a
2162          typespec was given, we already know the string length and want the one
2163          specified there.  */
2164       if (typespec_chararray_ctor && expr->ts.u.cl->length
2165           && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2166         {
2167           gfc_se length_se;
2168
2169           const_string = false;
2170           gfc_init_se (&length_se, NULL);
2171           gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2172                               gfc_charlen_type_node);
2173           ss_info->string_length = length_se.expr;
2174           gfc_add_block_to_block (&loop->pre, &length_se.pre);
2175           gfc_add_block_to_block (&loop->post, &length_se.post);
2176         }
2177       else
2178         const_string = get_array_ctor_strlen (&loop->pre, c,
2179                                               &ss_info->string_length);
2180
2181       /* Complex character array constructors should have been taken care of
2182          and not end up here.  */
2183       gcc_assert (ss_info->string_length);
2184
2185       expr->ts.u.cl->backend_decl = ss_info->string_length;
2186
2187       type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2188       if (const_string)
2189         type = build_pointer_type (type);
2190     }
2191   else
2192     type = gfc_typenode_for_spec (&expr->ts);
2193
2194   /* See if the constructor determines the loop bounds.  */
2195   dynamic = false;
2196
2197   loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2198
2199   if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2200     {
2201       /* We have a multidimensional parameter.  */
2202       for (s = ss; s; s = s->parent)
2203         {
2204           int n;
2205           for (n = 0; n < s->loop->dimen; n++)
2206             {
2207               s->loop->from[n] = gfc_index_zero_node;
2208               s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2209                                                      gfc_index_integer_kind);
2210               s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2211                                                 gfc_array_index_type,
2212                                                 s->loop->to[n],
2213                                                 gfc_index_one_node);
2214             }
2215         }
2216     }
2217
2218   if (*loop_ubound0 == NULL_TREE)
2219     {
2220       mpz_t size;
2221
2222       /* We should have a 1-dimensional, zero-based loop.  */
2223       gcc_assert (loop->parent == NULL && loop->nested == NULL);
2224       gcc_assert (loop->dimen == 1);
2225       gcc_assert (integer_zerop (loop->from[0]));
2226
2227       /* Split the constructor size into a static part and a dynamic part.
2228          Allocate the static size up-front and record whether the dynamic
2229          size might be nonzero.  */
2230       mpz_init (size);
2231       dynamic = gfc_get_array_constructor_size (&size, c);
2232       mpz_sub_ui (size, size, 1);
2233       loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2234       mpz_clear (size);
2235     }
2236
2237   /* Special case constant array constructors.  */
2238   if (!dynamic)
2239     {
2240       unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2241       if (nelem > 0)
2242         {
2243           tree size = constant_array_constructor_loop_size (loop);
2244           if (size && compare_tree_int (size, nelem) == 0)
2245             {
2246               trans_constant_array_constructor (ss, type);
2247               goto finish;
2248             }
2249         }
2250     }
2251
2252   if (TREE_CODE (*loop_ubound0) == VAR_DECL)
2253     dynamic = true;
2254
2255   gfc_trans_create_temp_array (&loop->pre, &loop->post, ss, type, NULL_TREE,
2256                                dynamic, true, false, where);
2257
2258   desc = ss_info->data.array.descriptor;
2259   offset = gfc_index_zero_node;
2260   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2261   TREE_NO_WARNING (offsetvar) = 1;
2262   TREE_USED (offsetvar) = 0;
2263   gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
2264                                      &offset, &offsetvar, dynamic);
2265
2266   /* If the array grows dynamically, the upper bound of the loop variable
2267      is determined by the array's final upper bound.  */
2268   if (dynamic)
2269     {
2270       tmp = fold_build2_loc (input_location, MINUS_EXPR,
2271                              gfc_array_index_type,
2272                              offsetvar, gfc_index_one_node);
2273       tmp = gfc_evaluate_now (tmp, &loop->pre);
2274       gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2275       if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
2276         gfc_add_modify (&loop->pre, *loop_ubound0, tmp);
2277       else
2278         *loop_ubound0 = tmp;
2279     }
2280
2281   if (TREE_USED (offsetvar))
2282     pushdecl (offsetvar);
2283   else
2284     gcc_assert (INTEGER_CST_P (offset));
2285
2286 #if 0
2287   /* Disable bound checking for now because it's probably broken.  */
2288   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2289     {
2290       gcc_unreachable ();
2291     }
2292 #endif
2293
2294 finish:
2295   /* Restore old values of globals.  */
2296   first_len = old_first_len;
2297   first_len_val = old_first_len_val;
2298   typespec_chararray_ctor = old_typespec_chararray_ctor;
2299 }
2300
2301
2302 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2303    called after evaluating all of INFO's vector dimensions.  Go through
2304    each such vector dimension and see if we can now fill in any missing
2305    loop bounds.  */
2306
2307 static void
2308 set_vector_loop_bounds (gfc_ss * ss)
2309 {
2310   gfc_loopinfo *loop;
2311   gfc_array_info *info;
2312   gfc_se se;
2313   tree tmp;
2314   tree desc;
2315   tree zero;
2316   int n;
2317   int dim;
2318
2319   info = &ss->info->data.array;
2320
2321   for (; ss; ss = ss->parent)
2322     {
2323       loop = ss->loop;
2324
2325       for (n = 0; n < loop->dimen; n++)
2326         {
2327           dim = ss->dim[n];
2328           if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2329               || loop->to[n] != NULL)
2330             continue;
2331
2332           /* Loop variable N indexes vector dimension DIM, and we don't
2333              yet know the upper bound of loop variable N.  Set it to the
2334              difference between the vector's upper and lower bounds.  */
2335           gcc_assert (loop->from[n] == gfc_index_zero_node);
2336           gcc_assert (info->subscript[dim]
2337                       && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2338
2339           gfc_init_se (&se, NULL);
2340           desc = info->subscript[dim]->info->data.array.descriptor;
2341           zero = gfc_rank_cst[0];
2342           tmp = fold_build2_loc (input_location, MINUS_EXPR,
2343                              gfc_array_index_type,
2344                              gfc_conv_descriptor_ubound_get (desc, zero),
2345                              gfc_conv_descriptor_lbound_get (desc, zero));
2346           tmp = gfc_evaluate_now (tmp, &loop->pre);
2347           loop->to[n] = tmp;
2348         }
2349     }
2350 }
2351
2352
2353 /* Add the pre and post chains for all the scalar expressions in a SS chain
2354    to loop.  This is called after the loop parameters have been calculated,
2355    but before the actual scalarizing loops.  */
2356
2357 static void
2358 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2359                       locus * where)
2360 {
2361   gfc_loopinfo *nested_loop;
2362   gfc_se se;
2363   gfc_ss_info *ss_info;
2364   gfc_array_info *info;
2365   gfc_expr *expr;
2366   bool skip_nested = false;
2367   int n;
2368
2369   /* TODO: This can generate bad code if there are ordering dependencies,
2370      e.g., a callee allocated function and an unknown size constructor.  */
2371   gcc_assert (ss != NULL);
2372
2373   for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2374     {
2375       gcc_assert (ss);
2376
2377       /* Cross loop arrays are handled from within the most nested loop.  */
2378       if (ss->nested_ss != NULL)
2379         continue;
2380
2381       ss_info = ss->info;
2382       expr = ss_info->expr;
2383       info = &ss_info->data.array;
2384
2385       switch (ss_info->type)
2386         {
2387         case GFC_SS_SCALAR:
2388           /* Scalar expression.  Evaluate this now.  This includes elemental
2389              dimension indices, but not array section bounds.  */
2390           gfc_init_se (&se, NULL);
2391           gfc_conv_expr (&se, expr);
2392           gfc_add_block_to_block (&loop->pre, &se.pre);
2393
2394           if (expr->ts.type != BT_CHARACTER)
2395             {
2396               /* Move the evaluation of scalar expressions outside the
2397                  scalarization loop, except for WHERE assignments.  */
2398               if (subscript)
2399                 se.expr = convert(gfc_array_index_type, se.expr);
2400               if (!ss_info->where)
2401                 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2402               gfc_add_block_to_block (&loop->pre, &se.post);
2403             }
2404           else
2405             gfc_add_block_to_block (&loop->post, &se.post);
2406
2407           ss_info->data.scalar.value = se.expr;
2408           ss_info->string_length = se.string_length;
2409           break;
2410
2411         case GFC_SS_REFERENCE:
2412           /* Scalar argument to elemental procedure.  Evaluate this
2413              now.  */
2414           gfc_init_se (&se, NULL);
2415           gfc_conv_expr (&se, expr);
2416           gfc_add_block_to_block (&loop->pre, &se.pre);
2417           gfc_add_block_to_block (&loop->post, &se.post);
2418
2419           ss_info->data.scalar.value = gfc_evaluate_now (se.expr, &loop->pre);
2420           ss_info->string_length = se.string_length;
2421           break;
2422
2423         case GFC_SS_SECTION:
2424           /* Add the expressions for scalar and vector subscripts.  */
2425           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2426             if (info->subscript[n])
2427               {
2428                 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2429                 /* The recursive call will have taken care of the nested loops.
2430                    No need to do it twice.  */
2431                 skip_nested = true;
2432               }
2433
2434           set_vector_loop_bounds (ss);
2435           break;
2436
2437         case GFC_SS_VECTOR:
2438           /* Get the vector's descriptor and store it in SS.  */
2439           gfc_init_se (&se, NULL);
2440           gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2441           gfc_add_block_to_block (&loop->pre, &se.pre);
2442           gfc_add_block_to_block (&loop->post, &se.post);
2443           info->descriptor = se.expr;
2444           break;
2445
2446         case GFC_SS_INTRINSIC:
2447           gfc_add_intrinsic_ss_code (loop, ss);
2448           break;
2449
2450         case GFC_SS_FUNCTION:
2451           /* Array function return value.  We call the function and save its
2452              result in a temporary for use inside the loop.  */
2453           gfc_init_se (&se, NULL);
2454           se.loop = loop;
2455           se.ss = ss;
2456           gfc_conv_expr (&se, expr);
2457           gfc_add_block_to_block (&loop->pre, &se.pre);
2458           gfc_add_block_to_block (&loop->post, &se.post);
2459           ss_info->string_length = se.string_length;
2460           break;
2461
2462         case GFC_SS_CONSTRUCTOR:
2463           if (expr->ts.type == BT_CHARACTER
2464               && ss_info->string_length == NULL
2465               && expr->ts.u.cl
2466               && expr->ts.u.cl->length)
2467             {
2468               gfc_init_se (&se, NULL);
2469               gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2470                                   gfc_charlen_type_node);
2471               ss_info->string_length = se.expr;
2472               gfc_add_block_to_block (&loop->pre, &se.pre);
2473               gfc_add_block_to_block (&loop->post, &se.post);
2474             }
2475           trans_array_constructor (ss, where);
2476           break;
2477
2478         case GFC_SS_TEMP:
2479         case GFC_SS_COMPONENT:
2480           /* Do nothing.  These are handled elsewhere.  */
2481           break;
2482
2483         default:
2484           gcc_unreachable ();
2485         }
2486     }
2487
2488   if (!skip_nested)
2489     for (nested_loop = loop->nested; nested_loop;
2490          nested_loop = nested_loop->next)
2491       gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2492 }
2493
2494
2495 /* Translate expressions for the descriptor and data pointer of a SS.  */
2496 /*GCC ARRAYS*/
2497
2498 static void
2499 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2500 {
2501   gfc_se se;
2502   gfc_ss_info *ss_info;
2503   gfc_array_info *info;
2504   tree tmp;
2505
2506   ss_info = ss->info;
2507   info = &ss_info->data.array;
2508
2509   /* Get the descriptor for the array to be scalarized.  */
2510   gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2511   gfc_init_se (&se, NULL);
2512   se.descriptor_only = 1;
2513   gfc_conv_expr_lhs (&se, ss_info->expr);
2514   gfc_add_block_to_block (block, &se.pre);
2515   info->descriptor = se.expr;
2516   ss_info->string_length = se.string_length;
2517
2518   if (base)
2519     {
2520       /* Also the data pointer.  */
2521       tmp = gfc_conv_array_data (se.expr);
2522       /* If this is a variable or address of a variable we use it directly.
2523          Otherwise we must evaluate it now to avoid breaking dependency
2524          analysis by pulling the expressions for elemental array indices
2525          inside the loop.  */
2526       if (!(DECL_P (tmp)
2527             || (TREE_CODE (tmp) == ADDR_EXPR
2528                 && DECL_P (TREE_OPERAND (tmp, 0)))))
2529         tmp = gfc_evaluate_now (tmp, block);
2530       info->data = tmp;
2531
2532       tmp = gfc_conv_array_offset (se.expr);
2533       info->offset = gfc_evaluate_now (tmp, block);
2534
2535       /* Make absolutely sure that the saved_offset is indeed saved
2536          so that the variable is still accessible after the loops
2537          are translated.  */
2538       info->saved_offset = info->offset;
2539     }
2540 }
2541
2542
2543 /* Initialize a gfc_loopinfo structure.  */
2544
2545 void
2546 gfc_init_loopinfo (gfc_loopinfo * loop)
2547 {
2548   int n;
2549
2550   memset (loop, 0, sizeof (gfc_loopinfo));
2551   gfc_init_block (&loop->pre);
2552   gfc_init_block (&loop->post);
2553
2554   /* Initially scalarize in order and default to no loop reversal.  */
2555   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2556     {
2557       loop->order[n] = n;
2558       loop->reverse[n] = GFC_INHIBIT_REVERSE;
2559     }
2560
2561   loop->ss = gfc_ss_terminator;
2562 }
2563
2564
2565 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2566    chain.  */
2567
2568 void
2569 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2570 {
2571   se->loop = loop;
2572 }
2573
2574
2575 /* Return an expression for the data pointer of an array.  */
2576
2577 tree
2578 gfc_conv_array_data (tree descriptor)
2579 {
2580   tree type;
2581
2582   type = TREE_TYPE (descriptor);
2583   if (GFC_ARRAY_TYPE_P (type))
2584     {
2585       if (TREE_CODE (type) == POINTER_TYPE)
2586         return descriptor;
2587       else
2588         {
2589           /* Descriptorless arrays.  */
2590           return gfc_build_addr_expr (NULL_TREE, descriptor);
2591         }
2592     }
2593   else
2594     return gfc_conv_descriptor_data_get (descriptor);
2595 }
2596
2597
2598 /* Return an expression for the base offset of an array.  */
2599
2600 tree
2601 gfc_conv_array_offset (tree descriptor)
2602 {
2603   tree type;
2604
2605   type = TREE_TYPE (descriptor);
2606   if (GFC_ARRAY_TYPE_P (type))
2607     return GFC_TYPE_ARRAY_OFFSET (type);
2608   else
2609     return gfc_conv_descriptor_offset_get (descriptor);
2610 }
2611
2612
2613 /* Get an expression for the array stride.  */
2614
2615 tree
2616 gfc_conv_array_stride (tree descriptor, int dim)
2617 {
2618   tree tmp;
2619   tree type;
2620
2621   type = TREE_TYPE (descriptor);
2622
2623   /* For descriptorless arrays use the array size.  */
2624   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2625   if (tmp != NULL_TREE)
2626     return tmp;
2627
2628   tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2629   return tmp;
2630 }
2631
2632
2633 /* Like gfc_conv_array_stride, but for the lower bound.  */
2634
2635 tree
2636 gfc_conv_array_lbound (tree descriptor, int dim)
2637 {
2638   tree tmp;
2639   tree type;
2640
2641   type = TREE_TYPE (descriptor);
2642
2643   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2644   if (tmp != NULL_TREE)
2645     return tmp;
2646
2647   tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2648   return tmp;
2649 }
2650
2651
2652 /* Like gfc_conv_array_stride, but for the upper bound.  */
2653
2654 tree
2655 gfc_conv_array_ubound (tree descriptor, int dim)
2656 {
2657   tree tmp;
2658   tree type;
2659
2660   type = TREE_TYPE (descriptor);
2661
2662   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2663   if (tmp != NULL_TREE)
2664     return tmp;
2665
2666   /* This should only ever happen when passing an assumed shape array
2667      as an actual parameter.  The value will never be used.  */
2668   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2669     return gfc_index_zero_node;
2670
2671   tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2672   return tmp;
2673 }
2674
2675
2676 /* Generate code to perform an array index bound check.  */
2677
2678 static tree
2679 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2680                          locus * where, bool check_upper)
2681 {
2682   tree fault;
2683   tree tmp_lo, tmp_up;
2684   tree descriptor;
2685   char *msg;
2686   const char * name = NULL;
2687
2688   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2689     return index;
2690
2691   descriptor = ss->info->data.array.descriptor;
2692
2693   index = gfc_evaluate_now (index, &se->pre);
2694
2695   /* We find a name for the error message.  */
2696   name = ss->info->expr->symtree->n.sym->name;
2697   gcc_assert (name != NULL);
2698
2699   if (TREE_CODE (descriptor) == VAR_DECL)
2700     name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2701
2702   /* If upper bound is present, include both bounds in the error message.  */
2703   if (check_upper)
2704     {
2705       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2706       tmp_up = gfc_conv_array_ubound (descriptor, n);
2707
2708       if (name)
2709         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2710                   "outside of expected range (%%ld:%%ld)", n+1, name);
2711       else
2712         asprintf (&msg, "Index '%%ld' of dimension %d "
2713                   "outside of expected range (%%ld:%%ld)", n+1);
2714
2715       fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2716                                index, tmp_lo);
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       fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2722                                index, tmp_up);
2723       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2724                                fold_convert (long_integer_type_node, index),
2725                                fold_convert (long_integer_type_node, tmp_lo),
2726                                fold_convert (long_integer_type_node, tmp_up));
2727       free (msg);
2728     }
2729   else
2730     {
2731       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2732
2733       if (name)
2734         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2735                   "below lower bound of %%ld", n+1, name);
2736       else
2737         asprintf (&msg, "Index '%%ld' of dimension %d "
2738                   "below lower bound of %%ld", n+1);
2739
2740       fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2741                                index, tmp_lo);
2742       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2743                                fold_convert (long_integer_type_node, index),
2744                                fold_convert (long_integer_type_node, tmp_lo));
2745       free (msg);
2746     }
2747
2748   return index;
2749 }
2750
2751
2752 /* Return the offset for an index.  Performs bound checking for elemental
2753    dimensions.  Single element references are processed separately.
2754    DIM is the array dimension, I is the loop dimension.  */
2755
2756 static tree
2757 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2758                          gfc_array_ref * ar, tree stride)
2759 {
2760   gfc_array_info *info;
2761   tree index;
2762   tree desc;
2763   tree data;
2764
2765   info = &ss->info->data.array;
2766
2767   /* Get the index into the array for this dimension.  */
2768   if (ar)
2769     {
2770       gcc_assert (ar->type != AR_ELEMENT);
2771       switch (ar->dimen_type[dim])
2772         {
2773         case DIMEN_THIS_IMAGE:
2774           gcc_unreachable ();
2775           break;
2776         case DIMEN_ELEMENT:
2777           /* Elemental dimension.  */
2778           gcc_assert (info->subscript[dim]
2779                       && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2780           /* We've already translated this value outside the loop.  */
2781           index = info->subscript[dim]->info->data.scalar.value;
2782
2783           index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2784                                            ar->as->type != AS_ASSUMED_SIZE
2785                                            || dim < ar->dimen - 1);
2786           break;
2787
2788         case DIMEN_VECTOR:
2789           gcc_assert (info && se->loop);
2790           gcc_assert (info->subscript[dim]
2791                       && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2792           desc = info->subscript[dim]->info->data.array.descriptor;
2793
2794           /* Get a zero-based index into the vector.  */
2795           index = fold_build2_loc (input_location, MINUS_EXPR,
2796                                    gfc_array_index_type,
2797                                    se->loop->loopvar[i], se->loop->from[i]);
2798
2799           /* Multiply the index by the stride.  */
2800           index = fold_build2_loc (input_location, MULT_EXPR,
2801                                    gfc_array_index_type,
2802                                    index, gfc_conv_array_stride (desc, 0));
2803
2804           /* Read the vector to get an index into info->descriptor.  */
2805           data = build_fold_indirect_ref_loc (input_location,
2806                                           gfc_conv_array_data (desc));
2807           index = gfc_build_array_ref (data, index, NULL);
2808           index = gfc_evaluate_now (index, &se->pre);
2809           index = fold_convert (gfc_array_index_type, index);
2810
2811           /* Do any bounds checking on the final info->descriptor index.  */
2812           index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2813                                            ar->as->type != AS_ASSUMED_SIZE
2814                                            || dim < ar->dimen - 1);
2815           break;
2816
2817         case DIMEN_RANGE:
2818           /* Scalarized dimension.  */
2819           gcc_assert (info && se->loop);
2820
2821           /* Multiply the loop variable by the stride and delta.  */
2822           index = se->loop->loopvar[i];
2823           if (!integer_onep (info->stride[dim]))
2824             index = fold_build2_loc (input_location, MULT_EXPR,
2825                                      gfc_array_index_type, index,
2826                                      info->stride[dim]);
2827           if (!integer_zerop (info->delta[dim]))
2828             index = fold_build2_loc (input_location, PLUS_EXPR,
2829                                      gfc_array_index_type, index,
2830                                      info->delta[dim]);
2831           break;
2832
2833         default:
2834           gcc_unreachable ();
2835         }
2836     }
2837   else
2838     {
2839       /* Temporary array or derived type component.  */
2840       gcc_assert (se->loop);
2841       index = se->loop->loopvar[se->loop->order[i]];
2842
2843       /* Pointer functions can have stride[0] different from unity. 
2844          Use the stride returned by the function call and stored in
2845          the descriptor for the temporary.  */ 
2846       if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2847           && se->ss->info->expr
2848           && se->ss->info->expr->symtree
2849           && se->ss->info->expr->symtree->n.sym->result
2850           && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2851         stride = gfc_conv_descriptor_stride_get (info->descriptor,
2852                                                  gfc_rank_cst[dim]);
2853
2854       if (!integer_zerop (info->delta[dim]))
2855         index = fold_build2_loc (input_location, PLUS_EXPR,
2856                                  gfc_array_index_type, index, info->delta[dim]);
2857     }
2858
2859   /* Multiply by the stride.  */
2860   if (!integer_onep (stride))
2861     index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2862                              index, stride);
2863
2864   return index;
2865 }
2866
2867
2868 /* Build a scalarized reference to an array.  */
2869
2870 static void
2871 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2872 {
2873   gfc_array_info *info;
2874   tree decl = NULL_TREE;
2875   tree index;
2876   tree tmp;
2877   gfc_ss *ss;
2878   gfc_expr *expr;
2879   int n;
2880
2881   ss = se->ss;
2882   expr = ss->info->expr;
2883   info = &ss->info->data.array;
2884   if (ar)
2885     n = se->loop->order[0];
2886   else
2887     n = 0;
2888
2889   index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
2890   /* Add the offset for this dimension to the stored offset for all other
2891      dimensions.  */
2892   if (!integer_zerop (info->offset))
2893     index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2894                              index, info->offset);
2895
2896   if (expr && is_subref_array (expr))
2897     decl = expr->symtree->n.sym->backend_decl;
2898
2899   tmp = build_fold_indirect_ref_loc (input_location, info->data);
2900   se->expr = gfc_build_array_ref (tmp, index, decl);
2901 }
2902
2903
2904 /* Translate access of temporary array.  */
2905
2906 void
2907 gfc_conv_tmp_array_ref (gfc_se * se)
2908 {
2909   se->string_length = se->ss->info->string_length;
2910   gfc_conv_scalarized_array_ref (se, NULL);
2911   gfc_advance_se_ss_chain (se);
2912 }
2913
2914 /* Add T to the offset pair *OFFSET, *CST_OFFSET.  */
2915
2916 static void
2917 add_to_offset (tree *cst_offset, tree *offset, tree t)
2918 {
2919   if (TREE_CODE (t) == INTEGER_CST)
2920     *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
2921   else
2922     {
2923       if (!integer_zerop (*offset))
2924         *offset = fold_build2_loc (input_location, PLUS_EXPR,
2925                                    gfc_array_index_type, *offset, t);
2926       else
2927         *offset = t;
2928     }
2929 }
2930
2931 /* Build an array reference.  se->expr already holds the array descriptor.
2932    This should be either a variable, indirect variable reference or component
2933    reference.  For arrays which do not have a descriptor, se->expr will be
2934    the data pointer.
2935    a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2936
2937 void
2938 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2939                     locus * where)
2940 {
2941   int n;
2942   tree offset, cst_offset;
2943   tree tmp;
2944   tree stride;
2945   gfc_se indexse;
2946   gfc_se tmpse;
2947
2948   if (ar->dimen == 0)
2949     {
2950       gcc_assert (ar->codimen);
2951
2952       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
2953         se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
2954       else
2955         {
2956           if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
2957               && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
2958             se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
2959
2960           /* Use the actual tree type and not the wrapped coarray. */
2961           if (!se->want_pointer)
2962             se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
2963                                      se->expr);
2964         }
2965
2966       return;
2967     }
2968
2969   /* Handle scalarized references separately.  */
2970   if (ar->type != AR_ELEMENT)
2971     {
2972       gfc_conv_scalarized_array_ref (se, ar);
2973       gfc_advance_se_ss_chain (se);
2974       return;
2975     }
2976
2977   cst_offset = offset = gfc_index_zero_node;
2978   add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
2979
2980   /* Calculate the offsets from all the dimensions.  Make sure to associate
2981      the final offset so that we form a chain of loop invariant summands.  */
2982   for (n = ar->dimen - 1; n >= 0; n--)
2983     {
2984       /* Calculate the index for this dimension.  */
2985       gfc_init_se (&indexse, se);
2986       gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2987       gfc_add_block_to_block (&se->pre, &indexse.pre);
2988
2989       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2990         {
2991           /* Check array bounds.  */
2992           tree cond;
2993           char *msg;
2994
2995           /* Evaluate the indexse.expr only once.  */
2996           indexse.expr = save_expr (indexse.expr);
2997
2998           /* Lower bound.  */
2999           tmp = gfc_conv_array_lbound (se->expr, n);
3000           if (sym->attr.temporary)
3001             {
3002               gfc_init_se (&tmpse, se);
3003               gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3004                                   gfc_array_index_type);
3005               gfc_add_block_to_block (&se->pre, &tmpse.pre);
3006               tmp = tmpse.expr;
3007             }
3008
3009           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 
3010                                   indexse.expr, tmp);
3011           asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3012                     "below lower bound of %%ld", n+1, sym->name);
3013           gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3014                                    fold_convert (long_integer_type_node,
3015                                                  indexse.expr),
3016                                    fold_convert (long_integer_type_node, tmp));
3017           free (msg);
3018
3019           /* Upper bound, but not for the last dimension of assumed-size
3020              arrays.  */
3021           if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3022             {
3023               tmp = gfc_conv_array_ubound (se->expr, n);
3024               if (sym->attr.temporary)
3025                 {
3026                   gfc_init_se (&tmpse, se);
3027                   gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3028                                       gfc_array_index_type);
3029                   gfc_add_block_to_block (&se->pre, &tmpse.pre);
3030                   tmp = tmpse.expr;
3031                 }
3032
3033               cond = fold_build2_loc (input_location, GT_EXPR,
3034                                       boolean_type_node, indexse.expr, tmp);
3035               asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3036                         "above upper bound of %%ld", n+1, sym->name);
3037               gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3038                                    fold_convert (long_integer_type_node,
3039                                                  indexse.expr),
3040                                    fold_convert (long_integer_type_node, tmp));
3041               free (msg);
3042             }
3043         }
3044
3045       /* Multiply the index by the stride.  */
3046       stride = gfc_conv_array_stride (se->expr, n);
3047       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3048                              indexse.expr, stride);
3049
3050       /* And add it to the total.  */
3051       add_to_offset (&cst_offset, &offset, tmp);
3052     }
3053
3054   if (!integer_zerop (cst_offset))
3055     offset = fold_build2_loc (input_location, PLUS_EXPR,
3056                               gfc_array_index_type, offset, cst_offset);
3057
3058   /* Access the calculated element.  */
3059   tmp = gfc_conv_array_data (se->expr);
3060   tmp = build_fold_indirect_ref (tmp);
3061   se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
3062 }
3063
3064
3065 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3066    LOOP_DIM dimension (if any) to array's offset.  */
3067
3068 static void
3069 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3070                   gfc_array_ref *ar, int array_dim, int loop_dim)
3071 {
3072   gfc_se se;
3073   gfc_array_info *info;
3074   tree stride, index;
3075
3076   info = &ss->info->data.array;
3077
3078   gfc_init_se (&se, NULL);
3079   se.loop = loop;
3080   se.expr = info->descriptor;
3081   stride = gfc_conv_array_stride (info->descriptor, array_dim);
3082   index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3083   gfc_add_block_to_block (pblock, &se.pre);
3084
3085   info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3086                                   gfc_array_index_type,
3087                                   info->offset, index);
3088   info->offset = gfc_evaluate_now (info->offset, pblock);
3089 }
3090
3091
3092 /* Generate the code to be executed immediately before entering a
3093    scalarization loop.  */
3094
3095 static void
3096 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3097                          stmtblock_t * pblock)
3098 {
3099   tree stride;
3100   gfc_ss_info *ss_info;
3101   gfc_array_info *info;
3102   gfc_ss_type ss_type;
3103   gfc_ss *ss;
3104   gfc_array_ref *ar;
3105   int i;
3106
3107   /* This code will be executed before entering the scalarization loop
3108      for this dimension.  */
3109   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3110     {
3111       ss_info = ss->info;
3112
3113       if ((ss_info->useflags & flag) == 0)
3114         continue;
3115
3116       ss_type = ss_info->type;
3117       if (ss_type != GFC_SS_SECTION
3118           && ss_type != GFC_SS_FUNCTION
3119           && ss_type != GFC_SS_CONSTRUCTOR
3120           && ss_type != GFC_SS_COMPONENT)
3121         continue;
3122
3123       info = &ss_info->data.array;
3124
3125       gcc_assert (dim < ss->dimen);
3126       gcc_assert (ss->dimen == loop->dimen);
3127
3128       if (info->ref)
3129         ar = &info->ref->u.ar;
3130       else
3131         ar = NULL;
3132
3133       if (dim == loop->dimen - 1)
3134         i = 0;
3135       else
3136         i = dim + 1;
3137
3138       /* For the time being, there is no loop reordering.  */
3139       gcc_assert (i == loop->order[i]);
3140       i = loop->order[i];
3141
3142       if (dim == loop->dimen - 1)
3143         {
3144           stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]);
3145
3146           /* Calculate the stride of the innermost loop.  Hopefully this will
3147              allow the backend optimizers to do their stuff more effectively.
3148            */
3149           info->stride0 = gfc_evaluate_now (stride, pblock);
3150
3151           /* For the outermost loop calculate the offset due to any
3152              elemental dimensions.  It will have been initialized with the
3153              base offset of the array.  */
3154           if (info->ref)
3155             {
3156               for (i = 0; i < ar->dimen; i++)
3157                 {
3158                   if (ar->dimen_type[i] != DIMEN_ELEMENT)
3159                     continue;
3160
3161                   add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3162                 }
3163             }
3164         }
3165       else
3166         /* Add the offset for the previous loop dimension.  */
3167         add_array_offset (pblock, loop, ss, ar, ss->dim[i], i);
3168
3169       /* Remember this offset for the second loop.  */
3170       if (dim == loop->temp_dim - 1)
3171         info->saved_offset = info->offset;
3172     }
3173 }
3174
3175
3176 /* Start a scalarized expression.  Creates a scope and declares loop
3177    variables.  */
3178
3179 void
3180 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3181 {
3182   int dim;
3183   int n;
3184   int flags;
3185
3186   gcc_assert (!loop->array_parameter);
3187
3188   for (dim = loop->dimen - 1; dim >= 0; dim--)
3189     {
3190       n = loop->order[dim];
3191
3192       gfc_start_block (&loop->code[n]);
3193
3194       /* Create the loop variable.  */
3195       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3196
3197       if (dim < loop->temp_dim)
3198         flags = 3;
3199       else
3200         flags = 1;
3201       /* Calculate values that will be constant within this loop.  */
3202       gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3203     }
3204   gfc_start_block (pbody);
3205 }
3206
3207
3208 /* Generates the actual loop code for a scalarization loop.  */
3209
3210 void
3211 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3212                                stmtblock_t * pbody)
3213 {
3214   stmtblock_t block;
3215   tree cond;
3216   tree tmp;
3217   tree loopbody;
3218   tree exit_label;
3219   tree stmt;
3220   tree init;
3221   tree incr;
3222
3223   if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3224       == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3225       && n == loop->dimen - 1)
3226     {
3227       /* We create an OMP_FOR construct for the outermost scalarized loop.  */
3228       init = make_tree_vec (1);
3229       cond = make_tree_vec (1);
3230       incr = make_tree_vec (1);
3231
3232       /* Cycle statement is implemented with a goto.  Exit statement must not
3233          be present for this loop.  */
3234       exit_label = gfc_build_label_decl (NULL_TREE);
3235       TREE_USED (exit_label) = 1;
3236
3237       /* Label for cycle statements (if needed).  */
3238       tmp = build1_v (LABEL_EXPR, exit_label);
3239       gfc_add_expr_to_block (pbody, tmp);
3240
3241       stmt = make_node (OMP_FOR);
3242
3243       TREE_TYPE (stmt) = void_type_node;
3244       OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3245
3246       OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3247                                                  OMP_CLAUSE_SCHEDULE);
3248       OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3249         = OMP_CLAUSE_SCHEDULE_STATIC;
3250       if (ompws_flags & OMPWS_NOWAIT)
3251         OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3252           = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3253
3254       /* Initialize the loopvar.  */
3255       TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3256                                          loop->from[n]);
3257       OMP_FOR_INIT (stmt) = init;
3258       /* The exit condition.  */
3259       TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3260                                            boolean_type_node,
3261                                            loop->loopvar[n], loop->to[n]);
3262       SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3263       OMP_FOR_COND (stmt) = cond;
3264       /* Increment the loopvar.  */
3265       tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3266                         loop->loopvar[n], gfc_index_one_node);
3267       TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3268           void_type_node, loop->loopvar[n], tmp);
3269       OMP_FOR_INCR (stmt) = incr;
3270
3271       ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3272       gfc_add_expr_to_block (&loop->code[n], stmt);
3273     }
3274   else
3275     {
3276       bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3277                              && (loop->temp_ss == NULL);
3278
3279       loopbody = gfc_finish_block (pbody);
3280
3281       if (reverse_loop)
3282         {
3283           tmp = loop->from[n];
3284           loop->from[n] = loop->to[n];
3285           loop->to[n] = tmp;
3286         }
3287
3288       /* Initialize the loopvar.  */
3289       if (loop->loopvar[n] != loop->from[n])
3290         gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3291
3292       exit_label = gfc_build_label_decl (NULL_TREE);
3293
3294       /* Generate the loop body.  */
3295       gfc_init_block (&block);
3296
3297       /* The exit condition.  */
3298       cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3299                           boolean_type_node, loop->loopvar[n], loop->to[n]);
3300       tmp = build1_v (GOTO_EXPR, exit_label);
3301       TREE_USED (exit_label) = 1;
3302       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3303       gfc_add_expr_to_block (&block, tmp);
3304
3305       /* The main body.  */
3306       gfc_add_expr_to_block (&block, loopbody);
3307
3308       /* Increment the loopvar.  */
3309       tmp = fold_build2_loc (input_location,
3310                              reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3311                              gfc_array_index_type, loop->loopvar[n],
3312                              gfc_index_one_node);
3313
3314       gfc_add_modify (&block, loop->loopvar[n], tmp);
3315
3316       /* Build the loop.  */
3317       tmp = gfc_finish_block (&block);
3318       tmp = build1_v (LOOP_EXPR, tmp);
3319       gfc_add_expr_to_block (&loop->code[n], tmp);
3320
3321       /* Add the exit label.  */
3322       tmp = build1_v (LABEL_EXPR, exit_label);
3323       gfc_add_expr_to_block (&loop->code[n], tmp);
3324     }
3325
3326 }
3327
3328
3329 /* Finishes and generates the loops for a scalarized expression.  */
3330
3331 void
3332 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3333 {
3334   int dim;
3335   int n;
3336   gfc_ss *ss;
3337   stmtblock_t *pblock;
3338   tree tmp;
3339
3340   pblock = body;
3341   /* Generate the loops.  */
3342   for (dim = 0; dim < loop->dimen; dim++)
3343     {
3344       n = loop->order[dim];
3345       gfc_trans_scalarized_loop_end (loop, n, pblock);
3346       loop->loopvar[n] = NULL_TREE;
3347       pblock = &loop->code[n];
3348     }
3349
3350   tmp = gfc_finish_block (pblock);
3351   gfc_add_expr_to_block (&loop->pre, tmp);
3352
3353   /* Clear all the used flags.  */
3354   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3355     if (ss->parent == NULL)
3356       ss->info->useflags = 0;
3357 }
3358
3359
3360 /* Finish the main body of a scalarized expression, and start the secondary
3361    copying body.  */
3362
3363 void
3364 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3365 {
3366   int dim;
3367   int n;
3368   stmtblock_t *pblock;
3369   gfc_ss *ss;
3370
3371   pblock = body;
3372   /* We finish as many loops as are used by the temporary.  */
3373   for (dim = 0; dim < loop->temp_dim - 1; dim++)
3374     {
3375       n = loop->order[dim];
3376       gfc_trans_scalarized_loop_end (loop, n, pblock);
3377       loop->loopvar[n] = NULL_TREE;
3378       pblock = &loop->code[n];
3379     }
3380
3381   /* We don't want to finish the outermost loop entirely.  */
3382   n = loop->order[loop->temp_dim - 1];
3383   gfc_trans_scalarized_loop_end (loop, n, pblock);
3384
3385   /* Restore the initial offsets.  */
3386   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3387     {
3388       gfc_ss_type ss_type;
3389       gfc_ss_info *ss_info;
3390
3391       ss_info = ss->info;
3392
3393       if ((ss_info->useflags & 2) == 0)
3394         continue;
3395
3396       ss_type = ss_info->type;
3397       if (ss_type != GFC_SS_SECTION
3398           && ss_type != GFC_SS_FUNCTION
3399           && ss_type != GFC_SS_CONSTRUCTOR
3400           && ss_type != GFC_SS_COMPONENT)
3401         continue;
3402
3403       ss_info->data.array.offset = ss_info->data.array.saved_offset;
3404     }
3405
3406   /* Restart all the inner loops we just finished.  */
3407   for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3408     {
3409       n = loop->order[dim];
3410
3411       gfc_start_block (&loop->code[n]);
3412
3413       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3414
3415       gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3416     }
3417
3418   /* Start a block for the secondary copying code.  */
3419   gfc_start_block (body);
3420 }
3421
3422
3423 /* Precalculate (either lower or upper) bound of an array section.
3424      BLOCK: Block in which the (pre)calculation code will go.
3425      BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3426      VALUES[DIM]: Specified bound (NULL <=> unspecified).