OSDN Git Service

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