OSDN Git Service

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