OSDN Git Service

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