OSDN Git Service

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