OSDN Git Service

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