OSDN Git Service

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