OSDN Git Service

34be30c19a179dce739f8db44023cf871041b1f9
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c
1 /* Expression translation
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
3    Foundation, Inc.
4    Contributed by Paul Brook <paul@nowt.org>
5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING.  If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
22 02110-1301, USA.  */
23
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr.  */
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "tree.h"
30 #include "convert.h"
31 #include "ggc.h"
32 #include "toplev.h"
33 #include "real.h"
34 #include "tree-gimple.h"
35 #include "langhooks.h"
36 #include "flags.h"
37 #include "gfortran.h"
38 #include "trans.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
43 #include "trans-stmt.h"
44 #include "dependency.h"
45
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48                                                  gfc_expr *);
49
50 /* Copy the scalarization loop variables.  */
51
52 static void
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 {
55   dest->ss = src->ss;
56   dest->loop = src->loop;
57 }
58
59
60 /* Initialize a simple expression holder.
61
62    Care must be taken when multiple se are created with the same parent.
63    The child se must be kept in sync.  The easiest way is to delay creation
64    of a child se until after after the previous se has been translated.  */
65
66 void
67 gfc_init_se (gfc_se * se, gfc_se * parent)
68 {
69   memset (se, 0, sizeof (gfc_se));
70   gfc_init_block (&se->pre);
71   gfc_init_block (&se->post);
72
73   se->parent = parent;
74
75   if (parent)
76     gfc_copy_se_loopvars (se, parent);
77 }
78
79
80 /* Advances to the next SS in the chain.  Use this rather than setting
81    se->ss = se->ss->next because all the parents needs to be kept in sync.
82    See gfc_init_se.  */
83
84 void
85 gfc_advance_se_ss_chain (gfc_se * se)
86 {
87   gfc_se *p;
88
89   gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90
91   p = se;
92   /* Walk down the parent chain.  */
93   while (p != NULL)
94     {
95       /* Simple consistency check.  */
96       gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
97
98       p->ss = p->ss->next;
99
100       p = p->parent;
101     }
102 }
103
104
105 /* Ensures the result of the expression as either a temporary variable
106    or a constant so that it can be used repeatedly.  */
107
108 void
109 gfc_make_safe_expr (gfc_se * se)
110 {
111   tree var;
112
113   if (CONSTANT_CLASS_P (se->expr))
114     return;
115
116   /* We need a temporary for this result.  */
117   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118   gfc_add_modify_expr (&se->pre, var, se->expr);
119   se->expr = var;
120 }
121
122
123 /* Return an expression which determines if a dummy parameter is present.
124    Also used for arguments to procedures with multiple entry points.  */
125
126 tree
127 gfc_conv_expr_present (gfc_symbol * sym)
128 {
129   tree decl;
130
131   gcc_assert (sym->attr.dummy);
132
133   decl = gfc_get_symbol_decl (sym);
134   if (TREE_CODE (decl) != PARM_DECL)
135     {
136       /* Array parameters use a temporary descriptor, we want the real
137          parameter.  */
138       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141     }
142   return build2 (NE_EXPR, boolean_type_node, decl,
143                  fold_convert (TREE_TYPE (decl), null_pointer_node));
144 }
145
146
147 /* Converts a missing, dummy argument into a null or zero.  */
148
149 void
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
151 {
152   tree present;
153   tree tmp;
154
155   present = gfc_conv_expr_present (arg->symtree->n.sym);
156   tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
157                 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
158
159   tmp = gfc_evaluate_now (tmp, &se->pre);
160   se->expr = tmp;
161   if (ts.type == BT_CHARACTER)
162     {
163       tmp = build_int_cst (gfc_charlen_type_node, 0);
164       tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
165                     se->string_length, tmp);
166       tmp = gfc_evaluate_now (tmp, &se->pre);
167       se->string_length = tmp;
168     }
169   return;
170 }
171
172
173 /* Get the character length of an expression, looking through gfc_refs
174    if necessary.  */
175
176 tree
177 gfc_get_expr_charlen (gfc_expr *e)
178 {
179   gfc_ref *r;
180   tree length;
181
182   gcc_assert (e->expr_type == EXPR_VARIABLE 
183               && e->ts.type == BT_CHARACTER);
184   
185   length = NULL; /* To silence compiler warning.  */
186
187   /* First candidate: if the variable is of type CHARACTER, the
188      expression's length could be the length of the character
189      variable.  */
190   if (e->symtree->n.sym->ts.type == BT_CHARACTER)
191     length = e->symtree->n.sym->ts.cl->backend_decl;
192
193   /* Look through the reference chain for component references.  */
194   for (r = e->ref; r; r = r->next)
195     {
196       switch (r->type)
197         {
198         case REF_COMPONENT:
199           if (r->u.c.component->ts.type == BT_CHARACTER)
200             length = r->u.c.component->ts.cl->backend_decl;
201           break;
202
203         case REF_ARRAY:
204           /* Do nothing.  */
205           break;
206
207         default:
208           /* We should never got substring references here.  These will be
209              broken down by the scalarizer.  */
210           gcc_unreachable ();
211         }
212     }
213
214   gcc_assert (length != NULL);
215   return length;
216 }
217
218   
219
220 /* Generate code to initialize a string length variable. Returns the
221    value.  */
222
223 void
224 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
225 {
226   gfc_se se;
227   tree tmp;
228
229   gfc_init_se (&se, NULL);
230   gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
231   se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
232                          build_int_cst (gfc_charlen_type_node, 0));
233   gfc_add_block_to_block (pblock, &se.pre);
234
235   tmp = cl->backend_decl;
236   gfc_add_modify_expr (pblock, tmp, se.expr);
237 }
238
239
240 static void
241 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
242                     const char *name, locus *where)
243 {
244   tree tmp;
245   tree type;
246   tree var;
247   tree fault;
248   gfc_se start;
249   gfc_se end;
250   char *msg;
251
252   type = gfc_get_character_type (kind, ref->u.ss.length);
253   type = build_pointer_type (type);
254
255   var = NULL_TREE;
256   gfc_init_se (&start, se);
257   gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
258   gfc_add_block_to_block (&se->pre, &start.pre);
259
260   if (integer_onep (start.expr))
261     gfc_conv_string_parameter (se);
262   else
263     {
264       /* Avoid multiple evaluation of substring start.  */
265       if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
266         start.expr = gfc_evaluate_now (start.expr, &se->pre);
267
268       /* Change the start of the string.  */
269       if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
270         tmp = se->expr;
271       else
272         tmp = build_fold_indirect_ref (se->expr);
273       tmp = gfc_build_array_ref (tmp, start.expr);
274       se->expr = gfc_build_addr_expr (type, tmp);
275     }
276
277   /* Length = end + 1 - start.  */
278   gfc_init_se (&end, se);
279   if (ref->u.ss.end == NULL)
280     end.expr = se->string_length;
281   else
282     {
283       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
284       gfc_add_block_to_block (&se->pre, &end.pre);
285     }
286   if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
287     end.expr = gfc_evaluate_now (end.expr, &se->pre);
288
289   if (flag_bounds_check)
290     {
291       tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
292                                    start.expr, end.expr);
293
294       /* Check lower bound.  */
295       fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
296                            build_int_cst (gfc_charlen_type_node, 1));
297       fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
298                            nonempty, fault);
299       if (name)
300         asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
301                   "is less than one", name);
302       else
303         asprintf (&msg, "Substring out of bounds: lower bound "
304                   "is less than one");
305       gfc_trans_runtime_check (fault, msg, &se->pre, where);
306       gfc_free (msg);
307
308       /* Check upper bound.  */
309       fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
310                            se->string_length);
311       fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
312                            nonempty, fault);
313       if (name)
314         asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
315                   "exceeds string length", name);
316       else
317         asprintf (&msg, "Substring out of bounds: upper bound "
318                   "exceeds string length");
319       gfc_trans_runtime_check (fault, msg, &se->pre, where);
320       gfc_free (msg);
321     }
322
323   tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
324                      build_int_cst (gfc_charlen_type_node, 1),
325                      start.expr);
326   tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
327   tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
328                      build_int_cst (gfc_charlen_type_node, 0));
329   se->string_length = tmp;
330 }
331
332
333 /* Convert a derived type component reference.  */
334
335 static void
336 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
337 {
338   gfc_component *c;
339   tree tmp;
340   tree decl;
341   tree field;
342
343   c = ref->u.c.component;
344
345   gcc_assert (c->backend_decl);
346
347   field = c->backend_decl;
348   gcc_assert (TREE_CODE (field) == FIELD_DECL);
349   decl = se->expr;
350   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
351
352   se->expr = tmp;
353
354   if (c->ts.type == BT_CHARACTER)
355     {
356       tmp = c->ts.cl->backend_decl;
357       /* Components must always be constant length.  */
358       gcc_assert (tmp && INTEGER_CST_P (tmp));
359       se->string_length = tmp;
360     }
361
362   if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
363     se->expr = build_fold_indirect_ref (se->expr);
364 }
365
366
367 /* Return the contents of a variable. Also handles reference/pointer
368    variables (all Fortran pointer references are implicit).  */
369
370 static void
371 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
372 {
373   gfc_ref *ref;
374   gfc_symbol *sym;
375   tree parent_decl;
376   int parent_flag;
377   bool return_value;
378   bool alternate_entry;
379   bool entry_master;
380
381   sym = expr->symtree->n.sym;
382   if (se->ss != NULL)
383     {
384       /* Check that something hasn't gone horribly wrong.  */
385       gcc_assert (se->ss != gfc_ss_terminator);
386       gcc_assert (se->ss->expr == expr);
387
388       /* A scalarized term.  We already know the descriptor.  */
389       se->expr = se->ss->data.info.descriptor;
390       se->string_length = se->ss->string_length;
391       for (ref = se->ss->data.info.ref; ref; ref = ref->next)
392         if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
393           break;
394     }
395   else
396     {
397       tree se_expr = NULL_TREE;
398
399       se->expr = gfc_get_symbol_decl (sym);
400
401       /* Deal with references to a parent results or entries by storing
402          the current_function_decl and moving to the parent_decl.  */
403       return_value = sym->attr.function && sym->result == sym;
404       alternate_entry = sym->attr.function && sym->attr.entry
405                         && sym->result == sym;
406       entry_master = sym->attr.result
407                      && sym->ns->proc_name->attr.entry_master
408                      && !gfc_return_by_reference (sym->ns->proc_name);
409       parent_decl = DECL_CONTEXT (current_function_decl);
410
411       if ((se->expr == parent_decl && return_value)
412            || (sym->ns && sym->ns->proc_name
413                && parent_decl
414                && sym->ns->proc_name->backend_decl == parent_decl
415                && (alternate_entry || entry_master)))
416         parent_flag = 1;
417       else
418         parent_flag = 0;
419
420       /* Special case for assigning the return value of a function.
421          Self recursive functions must have an explicit return value.  */
422       if (return_value && (se->expr == current_function_decl || parent_flag))
423         se_expr = gfc_get_fake_result_decl (sym, parent_flag);
424
425       /* Similarly for alternate entry points.  */
426       else if (alternate_entry 
427                && (sym->ns->proc_name->backend_decl == current_function_decl
428                    || parent_flag))
429         {
430           gfc_entry_list *el = NULL;
431
432           for (el = sym->ns->entries; el; el = el->next)
433             if (sym == el->sym)
434               {
435                 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
436                 break;
437               }
438         }
439
440       else if (entry_master
441                && (sym->ns->proc_name->backend_decl == current_function_decl
442                    || parent_flag))
443         se_expr = gfc_get_fake_result_decl (sym, parent_flag);
444
445       if (se_expr)
446         se->expr = se_expr;
447
448       /* Procedure actual arguments.  */
449       else if (sym->attr.flavor == FL_PROCEDURE
450                && se->expr != current_function_decl)
451         {
452           gcc_assert (se->want_pointer);
453           if (!sym->attr.dummy)
454             {
455               gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
456               se->expr = build_fold_addr_expr (se->expr);
457             }
458           return;
459         }
460
461
462       /* Dereference the expression, where needed. Since characters
463          are entirely different from other types, they are treated 
464          separately.  */
465       if (sym->ts.type == BT_CHARACTER)
466         {
467           /* Dereference character pointer dummy arguments
468              or results.  */
469           if ((sym->attr.pointer || sym->attr.allocatable)
470               && (sym->attr.dummy
471                   || sym->attr.function
472                   || sym->attr.result))
473             se->expr = build_fold_indirect_ref (se->expr);
474
475           /* A character with VALUE attribute needs an address
476              expression.  */
477           if (sym->attr.value)
478             se->expr = build_fold_addr_expr (se->expr);
479
480         }
481       else if (!sym->attr.value)
482         {
483           /* Dereference non-character scalar dummy arguments.  */
484           if (sym->attr.dummy && !sym->attr.dimension)
485             se->expr = build_fold_indirect_ref (se->expr);
486
487           /* Dereference scalar hidden result.  */
488           if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
489               && (sym->attr.function || sym->attr.result)
490               && !sym->attr.dimension && !sym->attr.pointer)
491             se->expr = build_fold_indirect_ref (se->expr);
492
493           /* Dereference non-character pointer variables. 
494              These must be dummies, results, or scalars.  */
495           if ((sym->attr.pointer || sym->attr.allocatable)
496               && (sym->attr.dummy
497                   || sym->attr.function
498                   || sym->attr.result
499                   || !sym->attr.dimension))
500             se->expr = build_fold_indirect_ref (se->expr);
501         }
502
503       ref = expr->ref;
504     }
505
506   /* For character variables, also get the length.  */
507   if (sym->ts.type == BT_CHARACTER)
508     {
509       /* If the character length of an entry isn't set, get the length from
510          the master function instead.  */
511       if (sym->attr.entry && !sym->ts.cl->backend_decl)
512         se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
513       else
514         se->string_length = sym->ts.cl->backend_decl;
515       gcc_assert (se->string_length);
516     }
517
518   while (ref)
519     {
520       switch (ref->type)
521         {
522         case REF_ARRAY:
523           /* Return the descriptor if that's what we want and this is an array
524              section reference.  */
525           if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
526             return;
527 /* TODO: Pointers to single elements of array sections, eg elemental subs.  */
528           /* Return the descriptor for array pointers and allocations.  */
529           if (se->want_pointer
530               && ref->next == NULL && (se->descriptor_only))
531             return;
532
533           gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
534           /* Return a pointer to an element.  */
535           break;
536
537         case REF_COMPONENT:
538           gfc_conv_component_ref (se, ref);
539           break;
540
541         case REF_SUBSTRING:
542           gfc_conv_substring (se, ref, expr->ts.kind,
543                               expr->symtree->name, &expr->where);
544           break;
545
546         default:
547           gcc_unreachable ();
548           break;
549         }
550       ref = ref->next;
551     }
552   /* Pointer assignment, allocation or pass by reference.  Arrays are handled
553      separately.  */
554   if (se->want_pointer)
555     {
556       if (expr->ts.type == BT_CHARACTER)
557         gfc_conv_string_parameter (se);
558       else 
559         se->expr = build_fold_addr_expr (se->expr);
560     }
561 }
562
563
564 /* Unary ops are easy... Or they would be if ! was a valid op.  */
565
566 static void
567 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
568 {
569   gfc_se operand;
570   tree type;
571
572   gcc_assert (expr->ts.type != BT_CHARACTER);
573   /* Initialize the operand.  */
574   gfc_init_se (&operand, se);
575   gfc_conv_expr_val (&operand, expr->value.op.op1);
576   gfc_add_block_to_block (&se->pre, &operand.pre);
577
578   type = gfc_typenode_for_spec (&expr->ts);
579
580   /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
581      We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
582      All other unary operators have an equivalent GIMPLE unary operator.  */
583   if (code == TRUTH_NOT_EXPR)
584     se->expr = build2 (EQ_EXPR, type, operand.expr,
585                        build_int_cst (type, 0));
586   else
587     se->expr = build1 (code, type, operand.expr);
588
589 }
590
591 /* Expand power operator to optimal multiplications when a value is raised
592    to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
593    Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
594    Programming", 3rd Edition, 1998.  */
595
596 /* This code is mostly duplicated from expand_powi in the backend.
597    We establish the "optimal power tree" lookup table with the defined size.
598    The items in the table are the exponents used to calculate the index
599    exponents. Any integer n less than the value can get an "addition chain",
600    with the first node being one.  */
601 #define POWI_TABLE_SIZE 256
602
603 /* The table is from builtins.c.  */
604 static const unsigned char powi_table[POWI_TABLE_SIZE] =
605   {
606       0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
607       4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
608       8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
609      12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
610      16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
611      20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
612      24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
613      28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
614      32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
615      36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
616      40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
617      44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
618      48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
619      52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
620      56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
621      60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
622      64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
623      68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
624      72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
625      76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
626      80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
627      84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
628      88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
629      92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
630      96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
631     100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
632     104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
633     108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
634     112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
635     116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
636     120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
637     124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
638   };
639
640 /* If n is larger than lookup table's max index, we use the "window 
641    method".  */
642 #define POWI_WINDOW_SIZE 3
643
644 /* Recursive function to expand the power operator. The temporary 
645    values are put in tmpvar. The function returns tmpvar[1] ** n.  */
646 static tree
647 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
648 {
649   tree op0;
650   tree op1;
651   tree tmp;
652   int digit;
653
654   if (n < POWI_TABLE_SIZE)
655     {
656       if (tmpvar[n])
657         return tmpvar[n];
658
659       op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
660       op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
661     }
662   else if (n & 1)
663     {
664       digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
665       op0 = gfc_conv_powi (se, n - digit, tmpvar);
666       op1 = gfc_conv_powi (se, digit, tmpvar);
667     }
668   else
669     {
670       op0 = gfc_conv_powi (se, n >> 1, tmpvar);
671       op1 = op0;
672     }
673
674   tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
675   tmp = gfc_evaluate_now (tmp, &se->pre);
676
677   if (n < POWI_TABLE_SIZE)
678     tmpvar[n] = tmp;
679
680   return tmp;
681 }
682
683
684 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
685    return 1. Else return 0 and a call to runtime library functions
686    will have to be built.  */
687 static int
688 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
689 {
690   tree cond;
691   tree tmp;
692   tree type;
693   tree vartmp[POWI_TABLE_SIZE];
694   HOST_WIDE_INT m;
695   unsigned HOST_WIDE_INT n;
696   int sgn;
697
698   /* If exponent is too large, we won't expand it anyway, so don't bother
699      with large integer values.  */
700   if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
701     return 0;
702
703   m = double_int_to_shwi (TREE_INT_CST (rhs));
704   /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
705      of the asymmetric range of the integer type.  */
706   n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
707   
708   type = TREE_TYPE (lhs);
709   sgn = tree_int_cst_sgn (rhs);
710
711   if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
712        || optimize_size) && (m > 2 || m < -1))
713     return 0;
714
715   /* rhs == 0  */
716   if (sgn == 0)
717     {
718       se->expr = gfc_build_const (type, integer_one_node);
719       return 1;
720     }
721
722   /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
723   if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
724     {
725       tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
726                     build_int_cst (TREE_TYPE (lhs), -1));
727       cond = build2 (EQ_EXPR, boolean_type_node, lhs,
728                      build_int_cst (TREE_TYPE (lhs), 1));
729
730       /* If rhs is even,
731          result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
732       if ((n & 1) == 0)
733         {
734           tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
735           se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
736                              build_int_cst (type, 0));
737           return 1;
738         }
739       /* If rhs is odd,
740          result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
741       tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
742                     build_int_cst (type, 0));
743       se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
744       return 1;
745     }
746
747   memset (vartmp, 0, sizeof (vartmp));
748   vartmp[1] = lhs;
749   if (sgn == -1)
750     {
751       tmp = gfc_build_const (type, integer_one_node);
752       vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
753     }
754
755   se->expr = gfc_conv_powi (se, n, vartmp);
756
757   return 1;
758 }
759
760
761 /* Power op (**).  Constant integer exponent has special handling.  */
762
763 static void
764 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
765 {
766   tree gfc_int4_type_node;
767   int kind;
768   int ikind;
769   gfc_se lse;
770   gfc_se rse;
771   tree fndecl;
772
773   gfc_init_se (&lse, se);
774   gfc_conv_expr_val (&lse, expr->value.op.op1);
775   lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
776   gfc_add_block_to_block (&se->pre, &lse.pre);
777
778   gfc_init_se (&rse, se);
779   gfc_conv_expr_val (&rse, expr->value.op.op2);
780   gfc_add_block_to_block (&se->pre, &rse.pre);
781
782   if (expr->value.op.op2->ts.type == BT_INTEGER
783          && expr->value.op.op2->expr_type == EXPR_CONSTANT)
784     if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
785       return;        
786
787   gfc_int4_type_node = gfc_get_int_type (4);
788
789   kind = expr->value.op.op1->ts.kind;
790   switch (expr->value.op.op2->ts.type)
791     {
792     case BT_INTEGER:
793       ikind = expr->value.op.op2->ts.kind;
794       switch (ikind)
795         {
796         case 1:
797         case 2:
798           rse.expr = convert (gfc_int4_type_node, rse.expr);
799           /* Fall through.  */
800
801         case 4:
802           ikind = 0;
803           break;
804           
805         case 8:
806           ikind = 1;
807           break;
808
809         case 16:
810           ikind = 2;
811           break;
812
813         default:
814           gcc_unreachable ();
815         }
816       switch (kind)
817         {
818         case 1:
819         case 2:
820           if (expr->value.op.op1->ts.type == BT_INTEGER)
821             lse.expr = convert (gfc_int4_type_node, lse.expr);
822           else
823             gcc_unreachable ();
824           /* Fall through.  */
825
826         case 4:
827           kind = 0;
828           break;
829           
830         case 8:
831           kind = 1;
832           break;
833
834         case 10:
835           kind = 2;
836           break;
837
838         case 16:
839           kind = 3;
840           break;
841
842         default:
843           gcc_unreachable ();
844         }
845       
846       switch (expr->value.op.op1->ts.type)
847         {
848         case BT_INTEGER:
849           if (kind == 3) /* Case 16 was not handled properly above.  */
850             kind = 2;
851           fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
852           break;
853
854         case BT_REAL:
855           fndecl = gfor_fndecl_math_powi[kind][ikind].real;
856           break;
857
858         case BT_COMPLEX:
859           fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
860           break;
861
862         default:
863           gcc_unreachable ();
864         }
865       break;
866
867     case BT_REAL:
868       switch (kind)
869         {
870         case 4:
871           fndecl = built_in_decls[BUILT_IN_POWF];
872           break;
873         case 8:
874           fndecl = built_in_decls[BUILT_IN_POW];
875           break;
876         case 10:
877         case 16:
878           fndecl = built_in_decls[BUILT_IN_POWL];
879           break;
880         default:
881           gcc_unreachable ();
882         }
883       break;
884
885     case BT_COMPLEX:
886       switch (kind)
887         {
888         case 4:
889           fndecl = gfor_fndecl_math_cpowf;
890           break;
891         case 8:
892           fndecl = gfor_fndecl_math_cpow;
893           break;
894         case 10:
895           fndecl = gfor_fndecl_math_cpowl10;
896           break;
897         case 16:
898           fndecl = gfor_fndecl_math_cpowl16;
899           break;
900         default:
901           gcc_unreachable ();
902         }
903       break;
904
905     default:
906       gcc_unreachable ();
907       break;
908     }
909
910   se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
911 }
912
913
914 /* Generate code to allocate a string temporary.  */
915
916 tree
917 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
918 {
919   tree var;
920   tree tmp;
921
922   gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
923
924   if (gfc_can_put_var_on_stack (len))
925     {
926       /* Create a temporary variable to hold the result.  */
927       tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
928                          build_int_cst (gfc_charlen_type_node, 1));
929       tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
930       tmp = build_array_type (gfc_character1_type_node, tmp);
931       var = gfc_create_var (tmp, "str");
932       var = gfc_build_addr_expr (type, var);
933     }
934   else
935     {
936       /* Allocate a temporary to hold the result.  */
937       var = gfc_create_var (type, "pstr");
938       tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, len);
939       tmp = convert (type, tmp);
940       gfc_add_modify_expr (&se->pre, var, tmp);
941
942       /* Free the temporary afterwards.  */
943       tmp = convert (pvoid_type_node, var);
944       tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
945       gfc_add_expr_to_block (&se->post, tmp);
946     }
947
948   return var;
949 }
950
951
952 /* Handle a string concatenation operation.  A temporary will be allocated to
953    hold the result.  */
954
955 static void
956 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
957 {
958   gfc_se lse;
959   gfc_se rse;
960   tree len;
961   tree type;
962   tree var;
963   tree tmp;
964
965   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
966           && expr->value.op.op2->ts.type == BT_CHARACTER);
967
968   gfc_init_se (&lse, se);
969   gfc_conv_expr (&lse, expr->value.op.op1);
970   gfc_conv_string_parameter (&lse);
971   gfc_init_se (&rse, se);
972   gfc_conv_expr (&rse, expr->value.op.op2);
973   gfc_conv_string_parameter (&rse);
974
975   gfc_add_block_to_block (&se->pre, &lse.pre);
976   gfc_add_block_to_block (&se->pre, &rse.pre);
977
978   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
979   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
980   if (len == NULL_TREE)
981     {
982       len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
983                          lse.string_length, rse.string_length);
984     }
985
986   type = build_pointer_type (type);
987
988   var = gfc_conv_string_tmp (se, type, len);
989
990   /* Do the actual concatenation.  */
991   tmp = build_call_expr (gfor_fndecl_concat_string, 6,
992                          len, var,
993                          lse.string_length, lse.expr,
994                          rse.string_length, rse.expr);
995   gfc_add_expr_to_block (&se->pre, tmp);
996
997   /* Add the cleanup for the operands.  */
998   gfc_add_block_to_block (&se->pre, &rse.post);
999   gfc_add_block_to_block (&se->pre, &lse.post);
1000
1001   se->expr = var;
1002   se->string_length = len;
1003 }
1004
1005 /* Translates an op expression. Common (binary) cases are handled by this
1006    function, others are passed on. Recursion is used in either case.
1007    We use the fact that (op1.ts == op2.ts) (except for the power
1008    operator **).
1009    Operators need no special handling for scalarized expressions as long as
1010    they call gfc_conv_simple_val to get their operands.
1011    Character strings get special handling.  */
1012
1013 static void
1014 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1015 {
1016   enum tree_code code;
1017   gfc_se lse;
1018   gfc_se rse;
1019   tree type;
1020   tree tmp;
1021   int lop;
1022   int checkstring;
1023
1024   checkstring = 0;
1025   lop = 0;
1026   switch (expr->value.op.operator)
1027     {
1028     case INTRINSIC_UPLUS:
1029     case INTRINSIC_PARENTHESES:
1030       gfc_conv_expr (se, expr->value.op.op1);
1031       return;
1032
1033     case INTRINSIC_UMINUS:
1034       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1035       return;
1036
1037     case INTRINSIC_NOT:
1038       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1039       return;
1040
1041     case INTRINSIC_PLUS:
1042       code = PLUS_EXPR;
1043       break;
1044
1045     case INTRINSIC_MINUS:
1046       code = MINUS_EXPR;
1047       break;
1048
1049     case INTRINSIC_TIMES:
1050       code = MULT_EXPR;
1051       break;
1052
1053     case INTRINSIC_DIVIDE:
1054       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1055          an integer, we must round towards zero, so we use a
1056          TRUNC_DIV_EXPR.  */
1057       if (expr->ts.type == BT_INTEGER)
1058         code = TRUNC_DIV_EXPR;
1059       else
1060         code = RDIV_EXPR;
1061       break;
1062
1063     case INTRINSIC_POWER:
1064       gfc_conv_power_op (se, expr);
1065       return;
1066
1067     case INTRINSIC_CONCAT:
1068       gfc_conv_concat_op (se, expr);
1069       return;
1070
1071     case INTRINSIC_AND:
1072       code = TRUTH_ANDIF_EXPR;
1073       lop = 1;
1074       break;
1075
1076     case INTRINSIC_OR:
1077       code = TRUTH_ORIF_EXPR;
1078       lop = 1;
1079       break;
1080
1081       /* EQV and NEQV only work on logicals, but since we represent them
1082          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
1083     case INTRINSIC_EQ:
1084     case INTRINSIC_EQV:
1085       code = EQ_EXPR;
1086       checkstring = 1;
1087       lop = 1;
1088       break;
1089
1090     case INTRINSIC_NE:
1091     case INTRINSIC_NEQV:
1092       code = NE_EXPR;
1093       checkstring = 1;
1094       lop = 1;
1095       break;
1096
1097     case INTRINSIC_GT:
1098       code = GT_EXPR;
1099       checkstring = 1;
1100       lop = 1;
1101       break;
1102
1103     case INTRINSIC_GE:
1104       code = GE_EXPR;
1105       checkstring = 1;
1106       lop = 1;
1107       break;
1108
1109     case INTRINSIC_LT:
1110       code = LT_EXPR;
1111       checkstring = 1;
1112       lop = 1;
1113       break;
1114
1115     case INTRINSIC_LE:
1116       code = LE_EXPR;
1117       checkstring = 1;
1118       lop = 1;
1119       break;
1120
1121     case INTRINSIC_USER:
1122     case INTRINSIC_ASSIGN:
1123       /* These should be converted into function calls by the frontend.  */
1124       gcc_unreachable ();
1125
1126     default:
1127       fatal_error ("Unknown intrinsic op");
1128       return;
1129     }
1130
1131   /* The only exception to this is **, which is handled separately anyway.  */
1132   gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1133
1134   if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1135     checkstring = 0;
1136
1137   /* lhs */
1138   gfc_init_se (&lse, se);
1139   gfc_conv_expr (&lse, expr->value.op.op1);
1140   gfc_add_block_to_block (&se->pre, &lse.pre);
1141
1142   /* rhs */
1143   gfc_init_se (&rse, se);
1144   gfc_conv_expr (&rse, expr->value.op.op2);
1145   gfc_add_block_to_block (&se->pre, &rse.pre);
1146
1147   if (checkstring)
1148     {
1149       gfc_conv_string_parameter (&lse);
1150       gfc_conv_string_parameter (&rse);
1151
1152       lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1153                                            rse.string_length, rse.expr);
1154       rse.expr = integer_zero_node;
1155       gfc_add_block_to_block (&lse.post, &rse.post);
1156     }
1157
1158   type = gfc_typenode_for_spec (&expr->ts);
1159
1160   if (lop)
1161     {
1162       /* The result of logical ops is always boolean_type_node.  */
1163       tmp = fold_build2 (code, type, lse.expr, rse.expr);
1164       se->expr = convert (type, tmp);
1165     }
1166   else
1167     se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1168
1169   /* Add the post blocks.  */
1170   gfc_add_block_to_block (&se->post, &rse.post);
1171   gfc_add_block_to_block (&se->post, &lse.post);
1172 }
1173
1174 /* If a string's length is one, we convert it to a single character.  */
1175
1176 static tree
1177 gfc_to_single_character (tree len, tree str)
1178 {
1179   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1180
1181   if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1182     && TREE_INT_CST_HIGH (len) == 0)
1183     {
1184       str = fold_convert (pchar_type_node, str);
1185       return build_fold_indirect_ref (str);
1186     }
1187
1188   return NULL_TREE;
1189 }
1190
1191 /* Compare two strings. If they are all single characters, the result is the
1192    subtraction of them. Otherwise, we build a library call.  */
1193
1194 tree
1195 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1196 {
1197   tree sc1;
1198   tree sc2;
1199   tree type;
1200   tree tmp;
1201
1202   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1203   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1204
1205   type = gfc_get_int_type (gfc_default_integer_kind);
1206
1207   sc1 = gfc_to_single_character (len1, str1);
1208   sc2 = gfc_to_single_character (len2, str2);
1209
1210   /* Deal with single character specially.  */
1211   if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1212     {
1213       sc1 = fold_convert (type, sc1);
1214       sc2 = fold_convert (type, sc2);
1215       tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1216     }
1217    else
1218      /* Build a call for the comparison.  */
1219      tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1220                             len1, str1, len2, str2);
1221   return tmp;
1222 }
1223
1224 static void
1225 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1226 {
1227   tree tmp;
1228
1229   if (sym->attr.dummy)
1230     {
1231       tmp = gfc_get_symbol_decl (sym);
1232       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1233               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1234     }
1235   else
1236     {
1237       if (!sym->backend_decl)
1238         sym->backend_decl = gfc_get_extern_function_decl (sym);
1239
1240       tmp = sym->backend_decl;
1241       if (sym->attr.cray_pointee)
1242         tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1243                        gfc_get_symbol_decl (sym->cp_pointer));
1244       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1245         {
1246           gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1247           tmp = build_fold_addr_expr (tmp);
1248         }
1249     }
1250   se->expr = tmp;
1251 }
1252
1253
1254 /* Translate the call for an elemental subroutine call used in an operator
1255    assignment.  This is a simplified version of gfc_conv_function_call.  */
1256
1257 tree
1258 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1259 {
1260   tree args;
1261   tree tmp;
1262   gfc_se se;
1263   stmtblock_t block;
1264
1265   /* Only elemental subroutines with two arguments.  */
1266   gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1267   gcc_assert (sym->formal->next->next == NULL);
1268
1269   gfc_init_block (&block);
1270
1271   gfc_add_block_to_block (&block, &lse->pre);
1272   gfc_add_block_to_block (&block, &rse->pre);
1273
1274   /* Build the argument list for the call, including hidden string lengths.  */
1275   args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1276   args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1277   if (lse->string_length != NULL_TREE)
1278     args = gfc_chainon_list (args, lse->string_length);
1279   if (rse->string_length != NULL_TREE)
1280     args = gfc_chainon_list (args, rse->string_length);    
1281
1282   /* Build the function call.  */
1283   gfc_init_se (&se, NULL);
1284   gfc_conv_function_val (&se, sym);
1285   tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1286   tmp = build_call_list (tmp, se.expr, args);
1287   gfc_add_expr_to_block (&block, tmp);
1288
1289   gfc_add_block_to_block (&block, &lse->post);
1290   gfc_add_block_to_block (&block, &rse->post);
1291
1292   return gfc_finish_block (&block);
1293 }
1294
1295
1296 /* Initialize MAPPING.  */
1297
1298 void
1299 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1300 {
1301   mapping->syms = NULL;
1302   mapping->charlens = NULL;
1303 }
1304
1305
1306 /* Free all memory held by MAPPING (but not MAPPING itself).  */
1307
1308 void
1309 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1310 {
1311   gfc_interface_sym_mapping *sym;
1312   gfc_interface_sym_mapping *nextsym;
1313   gfc_charlen *cl;
1314   gfc_charlen *nextcl;
1315
1316   for (sym = mapping->syms; sym; sym = nextsym)
1317     {
1318       nextsym = sym->next;
1319       gfc_free_symbol (sym->new->n.sym);
1320       gfc_free (sym->new);
1321       gfc_free (sym);
1322     }
1323   for (cl = mapping->charlens; cl; cl = nextcl)
1324     {
1325       nextcl = cl->next;
1326       gfc_free_expr (cl->length);
1327       gfc_free (cl);
1328     }
1329 }
1330
1331
1332 /* Return a copy of gfc_charlen CL.  Add the returned structure to
1333    MAPPING so that it will be freed by gfc_free_interface_mapping.  */
1334
1335 static gfc_charlen *
1336 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1337                                    gfc_charlen * cl)
1338 {
1339   gfc_charlen *new;
1340
1341   new = gfc_get_charlen ();
1342   new->next = mapping->charlens;
1343   new->length = gfc_copy_expr (cl->length);
1344
1345   mapping->charlens = new;
1346   return new;
1347 }
1348
1349
1350 /* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
1351    array variable that can be used as the actual argument for dummy
1352    argument SYM.  Add any initialization code to BLOCK.  PACKED is as
1353    for gfc_get_nodesc_array_type and DATA points to the first element
1354    in the passed array.  */
1355
1356 static tree
1357 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1358                                  gfc_packed packed, tree data)
1359 {
1360   tree type;
1361   tree var;
1362
1363   type = gfc_typenode_for_spec (&sym->ts);
1364   type = gfc_get_nodesc_array_type (type, sym->as, packed);
1365
1366   var = gfc_create_var (type, "ifm");
1367   gfc_add_modify_expr (block, var, fold_convert (type, data));
1368
1369   return var;
1370 }
1371
1372
1373 /* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
1374    and offset of descriptorless array type TYPE given that it has the same
1375    size as DESC.  Add any set-up code to BLOCK.  */
1376
1377 static void
1378 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1379 {
1380   int n;
1381   tree dim;
1382   tree offset;
1383   tree tmp;
1384
1385   offset = gfc_index_zero_node;
1386   for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1387     {
1388       dim = gfc_rank_cst[n];
1389       GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1390       if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1391         {
1392           GFC_TYPE_ARRAY_LBOUND (type, n)
1393                 = gfc_conv_descriptor_lbound (desc, dim);
1394           GFC_TYPE_ARRAY_UBOUND (type, n)
1395                 = gfc_conv_descriptor_ubound (desc, dim);
1396         }
1397       else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1398         {
1399           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1400                              gfc_conv_descriptor_ubound (desc, dim),
1401                              gfc_conv_descriptor_lbound (desc, dim));
1402           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1403                              GFC_TYPE_ARRAY_LBOUND (type, n),
1404                              tmp);
1405           tmp = gfc_evaluate_now (tmp, block);
1406           GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1407         }
1408       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1409                          GFC_TYPE_ARRAY_LBOUND (type, n),
1410                          GFC_TYPE_ARRAY_STRIDE (type, n));
1411       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1412     }
1413   offset = gfc_evaluate_now (offset, block);
1414   GFC_TYPE_ARRAY_OFFSET (type) = offset;
1415 }
1416
1417
1418 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1419    in SE.  The caller may still use se->expr and se->string_length after
1420    calling this function.  */
1421
1422 void
1423 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1424                            gfc_symbol * sym, gfc_se * se)
1425 {
1426   gfc_interface_sym_mapping *sm;
1427   tree desc;
1428   tree tmp;
1429   tree value;
1430   gfc_symbol *new_sym;
1431   gfc_symtree *root;
1432   gfc_symtree *new_symtree;
1433
1434   /* Create a new symbol to represent the actual argument.  */
1435   new_sym = gfc_new_symbol (sym->name, NULL);
1436   new_sym->ts = sym->ts;
1437   new_sym->attr.referenced = 1;
1438   new_sym->attr.dimension = sym->attr.dimension;
1439   new_sym->attr.pointer = sym->attr.pointer;
1440   new_sym->attr.allocatable = sym->attr.allocatable;
1441   new_sym->attr.flavor = sym->attr.flavor;
1442
1443   /* Create a fake symtree for it.  */
1444   root = NULL;
1445   new_symtree = gfc_new_symtree (&root, sym->name);
1446   new_symtree->n.sym = new_sym;
1447   gcc_assert (new_symtree == root);
1448
1449   /* Create a dummy->actual mapping.  */
1450   sm = gfc_getmem (sizeof (*sm));
1451   sm->next = mapping->syms;
1452   sm->old = sym;
1453   sm->new = new_symtree;
1454   mapping->syms = sm;
1455
1456   /* Stabilize the argument's value.  */
1457   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1458
1459   if (sym->ts.type == BT_CHARACTER)
1460     {
1461       /* Create a copy of the dummy argument's length.  */
1462       new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1463
1464       /* If the length is specified as "*", record the length that
1465          the caller is passing.  We should use the callee's length
1466          in all other cases.  */
1467       if (!new_sym->ts.cl->length)
1468         {
1469           se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1470           new_sym->ts.cl->backend_decl = se->string_length;
1471         }
1472     }
1473
1474   /* Use the passed value as-is if the argument is a function.  */
1475   if (sym->attr.flavor == FL_PROCEDURE)
1476     value = se->expr;
1477
1478   /* If the argument is either a string or a pointer to a string,
1479      convert it to a boundless character type.  */
1480   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1481     {
1482       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1483       tmp = build_pointer_type (tmp);
1484       if (sym->attr.pointer)
1485         value = build_fold_indirect_ref (se->expr);
1486       else
1487         value = se->expr;
1488       value = fold_convert (tmp, value);
1489     }
1490
1491   /* If the argument is a scalar, a pointer to an array or an allocatable,
1492      dereference it.  */
1493   else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1494     value = build_fold_indirect_ref (se->expr);
1495   
1496   /* For character(*), use the actual argument's descriptor.  */  
1497   else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1498     value = build_fold_indirect_ref (se->expr);
1499
1500   /* If the argument is an array descriptor, use it to determine
1501      information about the actual argument's shape.  */
1502   else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1503            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1504     {
1505       /* Get the actual argument's descriptor.  */
1506       desc = build_fold_indirect_ref (se->expr);
1507
1508       /* Create the replacement variable.  */
1509       tmp = gfc_conv_descriptor_data_get (desc);
1510       value = gfc_get_interface_mapping_array (&se->pre, sym,
1511                                                PACKED_NO, tmp);
1512
1513       /* Use DESC to work out the upper bounds, strides and offset.  */
1514       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1515     }
1516   else
1517     /* Otherwise we have a packed array.  */
1518     value = gfc_get_interface_mapping_array (&se->pre, sym,
1519                                              PACKED_FULL, se->expr);
1520
1521   new_sym->backend_decl = value;
1522 }
1523
1524
1525 /* Called once all dummy argument mappings have been added to MAPPING,
1526    but before the mapping is used to evaluate expressions.  Pre-evaluate
1527    the length of each argument, adding any initialization code to PRE and
1528    any finalization code to POST.  */
1529
1530 void
1531 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1532                               stmtblock_t * pre, stmtblock_t * post)
1533 {
1534   gfc_interface_sym_mapping *sym;
1535   gfc_expr *expr;
1536   gfc_se se;
1537
1538   for (sym = mapping->syms; sym; sym = sym->next)
1539     if (sym->new->n.sym->ts.type == BT_CHARACTER
1540         && !sym->new->n.sym->ts.cl->backend_decl)
1541       {
1542         expr = sym->new->n.sym->ts.cl->length;
1543         gfc_apply_interface_mapping_to_expr (mapping, expr);
1544         gfc_init_se (&se, NULL);
1545         gfc_conv_expr (&se, expr);
1546
1547         se.expr = gfc_evaluate_now (se.expr, &se.pre);
1548         gfc_add_block_to_block (pre, &se.pre);
1549         gfc_add_block_to_block (post, &se.post);
1550
1551         sym->new->n.sym->ts.cl->backend_decl = se.expr;
1552       }
1553 }
1554
1555
1556 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1557    constructor C.  */
1558
1559 static void
1560 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1561                                      gfc_constructor * c)
1562 {
1563   for (; c; c = c->next)
1564     {
1565       gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1566       if (c->iterator)
1567         {
1568           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1569           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1570           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1571         }
1572     }
1573 }
1574
1575
1576 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1577    reference REF.  */
1578
1579 static void
1580 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1581                                     gfc_ref * ref)
1582 {
1583   int n;
1584
1585   for (; ref; ref = ref->next)
1586     switch (ref->type)
1587       {
1588       case REF_ARRAY:
1589         for (n = 0; n < ref->u.ar.dimen; n++)
1590           {
1591             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1592             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1593             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1594           }
1595         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1596         break;
1597
1598       case REF_COMPONENT:
1599         break;
1600
1601       case REF_SUBSTRING:
1602         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1603         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1604         break;
1605       }
1606 }
1607
1608
1609 /* EXPR is a copy of an expression that appeared in the interface
1610    associated with MAPPING.  Walk it recursively looking for references to
1611    dummy arguments that MAPPING maps to actual arguments.  Replace each such
1612    reference with a reference to the associated actual argument.  */
1613
1614 static int
1615 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1616                                      gfc_expr * expr)
1617 {
1618   gfc_interface_sym_mapping *sym;
1619   gfc_actual_arglist *actual;
1620   int seen_result = 0;
1621
1622   if (!expr)
1623     return 0;
1624
1625   /* Copying an expression does not copy its length, so do that here.  */
1626   if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1627     {
1628       expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1629       gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1630     }
1631
1632   /* Apply the mapping to any references.  */
1633   gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1634
1635   /* ...and to the expression's symbol, if it has one.  */
1636   if (expr->symtree)
1637     for (sym = mapping->syms; sym; sym = sym->next)
1638       if (sym->old == expr->symtree->n.sym)
1639         expr->symtree = sym->new;
1640
1641   /* ...and to subexpressions in expr->value.  */
1642   switch (expr->expr_type)
1643     {
1644     case EXPR_VARIABLE:
1645       if (expr->symtree->n.sym->attr.result)
1646         seen_result = 1;
1647     case EXPR_CONSTANT:
1648     case EXPR_NULL:
1649     case EXPR_SUBSTRING:
1650       break;
1651
1652     case EXPR_OP:
1653       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1654       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1655       break;
1656
1657     case EXPR_FUNCTION:
1658       if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1659             && gfc_apply_interface_mapping_to_expr (mapping,
1660                         expr->value.function.actual->expr)
1661             && expr->value.function.esym == NULL
1662             && expr->value.function.isym != NULL
1663             && expr->value.function.isym->generic_id == GFC_ISYM_LEN)
1664         {
1665           gfc_expr *new_expr;
1666           new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1667           *expr = *new_expr;
1668           gfc_free (new_expr);
1669           gfc_apply_interface_mapping_to_expr (mapping, expr);
1670           break;
1671         }
1672
1673       for (sym = mapping->syms; sym; sym = sym->next)
1674         if (sym->old == expr->value.function.esym)
1675           expr->value.function.esym = sym->new->n.sym;
1676
1677       for (actual = expr->value.function.actual; actual; actual = actual->next)
1678         gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1679       break;
1680
1681     case EXPR_ARRAY:
1682     case EXPR_STRUCTURE:
1683       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1684       break;
1685     }
1686   return seen_result;
1687 }
1688
1689
1690 /* Evaluate interface expression EXPR using MAPPING.  Store the result
1691    in SE.  */
1692
1693 void
1694 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1695                              gfc_se * se, gfc_expr * expr)
1696 {
1697   expr = gfc_copy_expr (expr);
1698   gfc_apply_interface_mapping_to_expr (mapping, expr);
1699   gfc_conv_expr (se, expr);
1700   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1701   gfc_free_expr (expr);
1702 }
1703
1704 /* Returns a reference to a temporary array into which a component of
1705    an actual argument derived type array is copied and then returned
1706    after the function call.
1707    TODO Get rid of this kludge, when array descriptors are capable of
1708    handling arrays with a bigger stride in bytes than size.  */
1709
1710 void
1711 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1712                       int g77, sym_intent intent)
1713 {
1714   gfc_se lse;
1715   gfc_se rse;
1716   gfc_ss *lss;
1717   gfc_ss *rss;
1718   gfc_loopinfo loop;
1719   gfc_loopinfo loop2;
1720   gfc_ss_info *info;
1721   tree offset;
1722   tree tmp_index;
1723   tree tmp;
1724   tree base_type;
1725   stmtblock_t body;
1726   int n;
1727
1728   gcc_assert (expr->expr_type == EXPR_VARIABLE);
1729
1730   gfc_init_se (&lse, NULL);
1731   gfc_init_se (&rse, NULL);
1732
1733   /* Walk the argument expression.  */
1734   rss = gfc_walk_expr (expr);
1735
1736   gcc_assert (rss != gfc_ss_terminator);
1737  
1738   /* Initialize the scalarizer.  */
1739   gfc_init_loopinfo (&loop);
1740   gfc_add_ss_to_loop (&loop, rss);
1741
1742   /* Calculate the bounds of the scalarization.  */
1743   gfc_conv_ss_startstride (&loop);
1744
1745   /* Build an ss for the temporary.  */
1746   base_type = gfc_typenode_for_spec (&expr->ts);
1747   if (GFC_ARRAY_TYPE_P (base_type)
1748                 || GFC_DESCRIPTOR_TYPE_P (base_type))
1749     base_type = gfc_get_element_type (base_type);
1750
1751   loop.temp_ss = gfc_get_ss ();;
1752   loop.temp_ss->type = GFC_SS_TEMP;
1753   loop.temp_ss->data.temp.type = base_type;
1754
1755   if (expr->ts.type == BT_CHARACTER)
1756     {
1757       gfc_ref *char_ref = expr->ref;
1758
1759       for (; char_ref; char_ref = char_ref->next)
1760         if (char_ref->type == REF_SUBSTRING)
1761           {
1762             gfc_se tmp_se;
1763
1764             expr->ts.cl = gfc_get_charlen ();
1765             expr->ts.cl->next = char_ref->u.ss.length->next;
1766             char_ref->u.ss.length->next = expr->ts.cl;
1767
1768             gfc_init_se (&tmp_se, NULL);
1769             gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1770                                 gfc_array_index_type);
1771             tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1772                                tmp_se.expr, gfc_index_one_node);
1773             tmp = gfc_evaluate_now (tmp, &parmse->pre);
1774             gfc_init_se (&tmp_se, NULL);
1775             gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1776                                 gfc_array_index_type);
1777             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1778                                tmp, tmp_se.expr);
1779             expr->ts.cl->backend_decl = tmp;
1780
1781             break;
1782           }
1783       loop.temp_ss->data.temp.type
1784                 = gfc_typenode_for_spec (&expr->ts);
1785       loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1786     }
1787
1788   loop.temp_ss->data.temp.dimen = loop.dimen;
1789   loop.temp_ss->next = gfc_ss_terminator;
1790
1791   /* Associate the SS with the loop.  */
1792   gfc_add_ss_to_loop (&loop, loop.temp_ss);
1793
1794   /* Setup the scalarizing loops.  */
1795   gfc_conv_loop_setup (&loop);
1796
1797   /* Pass the temporary descriptor back to the caller.  */
1798   info = &loop.temp_ss->data.info;
1799   parmse->expr = info->descriptor;
1800
1801   /* Setup the gfc_se structures.  */
1802   gfc_copy_loopinfo_to_se (&lse, &loop);
1803   gfc_copy_loopinfo_to_se (&rse, &loop);
1804
1805   rse.ss = rss;
1806   lse.ss = loop.temp_ss;
1807   gfc_mark_ss_chain_used (rss, 1);
1808   gfc_mark_ss_chain_used (loop.temp_ss, 1);
1809
1810   /* Start the scalarized loop body.  */
1811   gfc_start_scalarized_body (&loop, &body);
1812
1813   /* Translate the expression.  */
1814   gfc_conv_expr (&rse, expr);
1815
1816   gfc_conv_tmp_array_ref (&lse);
1817   gfc_advance_se_ss_chain (&lse);
1818
1819   if (intent != INTENT_OUT)
1820     {
1821       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1822       gfc_add_expr_to_block (&body, tmp);
1823       gcc_assert (rse.ss == gfc_ss_terminator);
1824       gfc_trans_scalarizing_loops (&loop, &body);
1825     }
1826   else
1827     {
1828       /* Make sure that the temporary declaration survives by merging
1829        all the loop declarations into the current context.  */
1830       for (n = 0; n < loop.dimen; n++)
1831         {
1832           gfc_merge_block_scope (&body);
1833           body = loop.code[loop.order[n]];
1834         }
1835       gfc_merge_block_scope (&body);
1836     }
1837
1838   /* Add the post block after the second loop, so that any
1839      freeing of allocated memory is done at the right time.  */
1840   gfc_add_block_to_block (&parmse->pre, &loop.pre);
1841
1842   /**********Copy the temporary back again.*********/
1843
1844   gfc_init_se (&lse, NULL);
1845   gfc_init_se (&rse, NULL);
1846
1847   /* Walk the argument expression.  */
1848   lss = gfc_walk_expr (expr);
1849   rse.ss = loop.temp_ss;
1850   lse.ss = lss;
1851
1852   /* Initialize the scalarizer.  */
1853   gfc_init_loopinfo (&loop2);
1854   gfc_add_ss_to_loop (&loop2, lss);
1855
1856   /* Calculate the bounds of the scalarization.  */
1857   gfc_conv_ss_startstride (&loop2);
1858
1859   /* Setup the scalarizing loops.  */
1860   gfc_conv_loop_setup (&loop2);
1861
1862   gfc_copy_loopinfo_to_se (&lse, &loop2);
1863   gfc_copy_loopinfo_to_se (&rse, &loop2);
1864
1865   gfc_mark_ss_chain_used (lss, 1);
1866   gfc_mark_ss_chain_used (loop.temp_ss, 1);
1867
1868   /* Declare the variable to hold the temporary offset and start the
1869      scalarized loop body.  */
1870   offset = gfc_create_var (gfc_array_index_type, NULL);
1871   gfc_start_scalarized_body (&loop2, &body);
1872
1873   /* Build the offsets for the temporary from the loop variables.  The
1874      temporary array has lbounds of zero and strides of one in all
1875      dimensions, so this is very simple.  The offset is only computed
1876      outside the innermost loop, so the overall transfer could be
1877      optimized further.  */
1878   info = &rse.ss->data.info;
1879
1880   tmp_index = gfc_index_zero_node;
1881   for (n = info->dimen - 1; n > 0; n--)
1882     {
1883       tree tmp_str;
1884       tmp = rse.loop->loopvar[n];
1885       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1886                          tmp, rse.loop->from[n]);
1887       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1888                          tmp, tmp_index);
1889
1890       tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1891                              rse.loop->to[n-1], rse.loop->from[n-1]);
1892       tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1893                              tmp_str, gfc_index_one_node);
1894
1895       tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1896                                tmp, tmp_str);
1897     }
1898
1899   tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1900                            tmp_index, rse.loop->from[0]);
1901   gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1902
1903   tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1904                            rse.loop->loopvar[0], offset);
1905
1906   /* Now use the offset for the reference.  */
1907   tmp = build_fold_indirect_ref (info->data);
1908   rse.expr = gfc_build_array_ref (tmp, tmp_index);
1909
1910   if (expr->ts.type == BT_CHARACTER)
1911     rse.string_length = expr->ts.cl->backend_decl;
1912
1913   gfc_conv_expr (&lse, expr);
1914
1915   gcc_assert (lse.ss == gfc_ss_terminator);
1916
1917   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1918   gfc_add_expr_to_block (&body, tmp);
1919   
1920   /* Generate the copying loops.  */
1921   gfc_trans_scalarizing_loops (&loop2, &body);
1922
1923   /* Wrap the whole thing up by adding the second loop to the post-block
1924      and following it by the post-block of the first loop.  In this way,
1925      if the temporary needs freeing, it is done after use!  */
1926   if (intent != INTENT_IN)
1927     {
1928       gfc_add_block_to_block (&parmse->post, &loop2.pre);
1929       gfc_add_block_to_block (&parmse->post, &loop2.post);
1930     }
1931
1932   gfc_add_block_to_block (&parmse->post, &loop.post);
1933
1934   gfc_cleanup_loop (&loop);
1935   gfc_cleanup_loop (&loop2);
1936
1937   /* Pass the string length to the argument expression.  */
1938   if (expr->ts.type == BT_CHARACTER)
1939     parmse->string_length = expr->ts.cl->backend_decl;
1940
1941   /* We want either the address for the data or the address of the descriptor,
1942      depending on the mode of passing array arguments.  */
1943   if (g77)
1944     parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1945   else
1946     parmse->expr = build_fold_addr_expr (parmse->expr);
1947
1948   return;
1949 }
1950
1951 /* Is true if an array reference is followed by a component or substring
1952    reference.  */
1953
1954 bool
1955 is_aliased_array (gfc_expr * e)
1956 {
1957   gfc_ref * ref;
1958   bool seen_array;
1959
1960   seen_array = false;   
1961   for (ref = e->ref; ref; ref = ref->next)
1962     {
1963       if (ref->type == REF_ARRAY
1964             && ref->u.ar.type != AR_ELEMENT)
1965         seen_array = true;
1966
1967       if (seen_array
1968             && ref->type != REF_ARRAY)
1969         return seen_array;
1970     }
1971   return false;
1972 }
1973
1974 /* Generate the code for argument list functions.  */
1975
1976 static void
1977 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
1978 {
1979   /* Pass by value for g77 %VAL(arg), pass the address
1980      indirectly for %LOC, else by reference.  Thus %REF
1981      is a "do-nothing" and %LOC is the same as an F95
1982      pointer.  */
1983   if (strncmp (name, "%VAL", 4) == 0)
1984     gfc_conv_expr (se, expr);
1985   else if (strncmp (name, "%LOC", 4) == 0)
1986     {
1987       gfc_conv_expr_reference (se, expr);
1988       se->expr = gfc_build_addr_expr (NULL, se->expr);
1989     }
1990   else if (strncmp (name, "%REF", 4) == 0)
1991     gfc_conv_expr_reference (se, expr);
1992   else
1993     gfc_error ("Unknown argument list function at %L", &expr->where);
1994 }
1995
1996
1997 /* Generate code for a procedure call.  Note can return se->post != NULL.
1998    If se->direct_byref is set then se->expr contains the return parameter.
1999    Return nonzero, if the call has alternate specifiers.  */
2000
2001 int
2002 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2003                         gfc_actual_arglist * arg, tree append_args)
2004 {
2005   gfc_interface_mapping mapping;
2006   tree arglist;
2007   tree retargs;
2008   tree tmp;
2009   tree fntype;
2010   gfc_se parmse;
2011   gfc_ss *argss;
2012   gfc_ss_info *info;
2013   int byref;
2014   int parm_kind;
2015   tree type;
2016   tree var;
2017   tree len;
2018   tree stringargs;
2019   gfc_formal_arglist *formal;
2020   int has_alternate_specifier = 0;
2021   bool need_interface_mapping;
2022   bool callee_alloc;
2023   gfc_typespec ts;
2024   gfc_charlen cl;
2025   gfc_expr *e;
2026   gfc_symbol *fsym;
2027   stmtblock_t post;
2028   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2029
2030   arglist = NULL_TREE;
2031   retargs = NULL_TREE;
2032   stringargs = NULL_TREE;
2033   var = NULL_TREE;
2034   len = NULL_TREE;
2035
2036   if (se->ss != NULL)
2037     {
2038       if (!sym->attr.elemental)
2039         {
2040           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2041           if (se->ss->useflags)
2042             {
2043               gcc_assert (gfc_return_by_reference (sym)
2044                       && sym->result->attr.dimension);
2045               gcc_assert (se->loop != NULL);
2046
2047               /* Access the previously obtained result.  */
2048               gfc_conv_tmp_array_ref (se);
2049               gfc_advance_se_ss_chain (se);
2050               return 0;
2051             }
2052         }
2053       info = &se->ss->data.info;
2054     }
2055   else
2056     info = NULL;
2057
2058   gfc_init_block (&post);
2059   gfc_init_interface_mapping (&mapping);
2060   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2061                                   && sym->ts.cl->length
2062                                   && sym->ts.cl->length->expr_type
2063                                                 != EXPR_CONSTANT)
2064                               || sym->attr.dimension);
2065   formal = sym->formal;
2066   /* Evaluate the arguments.  */
2067   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2068     {
2069       e = arg->expr;
2070       fsym = formal ? formal->sym : NULL;
2071       parm_kind = MISSING;
2072       if (e == NULL)
2073         {
2074
2075           if (se->ignore_optional)
2076             {
2077               /* Some intrinsics have already been resolved to the correct
2078                  parameters.  */
2079               continue;
2080             }
2081           else if (arg->label)
2082             {
2083               has_alternate_specifier = 1;
2084               continue;
2085             }
2086           else
2087             {
2088               /* Pass a NULL pointer for an absent arg.  */
2089               gfc_init_se (&parmse, NULL);
2090               parmse.expr = null_pointer_node;
2091               if (arg->missing_arg_type == BT_CHARACTER)
2092                 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2093             }
2094         }
2095       else if (se->ss && se->ss->useflags)
2096         {
2097           /* An elemental function inside a scalarized loop.  */
2098           gfc_init_se (&parmse, se);
2099           gfc_conv_expr_reference (&parmse, e);
2100           parm_kind = ELEMENTAL;
2101         }
2102       else
2103         {
2104           /* A scalar or transformational function.  */
2105           gfc_init_se (&parmse, NULL);
2106           argss = gfc_walk_expr (e);
2107
2108           if (argss == gfc_ss_terminator)
2109             {
2110               parm_kind = SCALAR;
2111               if (fsym && fsym->attr.value)
2112                 {
2113                   gfc_conv_expr (&parmse, e);
2114                 }
2115               else if (arg->name && arg->name[0] == '%')
2116                 /* Argument list functions %VAL, %LOC and %REF are signalled
2117                    through arg->name.  */
2118                 conv_arglist_function (&parmse, arg->expr, arg->name);
2119               else if ((e->expr_type == EXPR_FUNCTION)
2120                           && e->symtree->n.sym->attr.pointer
2121                           && fsym && fsym->attr.target)
2122                 {
2123                   gfc_conv_expr (&parmse, e);
2124                   parmse.expr = build_fold_addr_expr (parmse.expr);
2125                 }
2126               else
2127                 {
2128                   gfc_conv_expr_reference (&parmse, e);
2129                   if (fsym && fsym->attr.pointer
2130                       && fsym->attr.flavor != FL_PROCEDURE
2131                       && e->expr_type != EXPR_NULL)
2132                     {
2133                       /* Scalar pointer dummy args require an extra level of
2134                          indirection. The null pointer already contains
2135                          this level of indirection.  */
2136                       parm_kind = SCALAR_POINTER;
2137                       parmse.expr = build_fold_addr_expr (parmse.expr);
2138                     }
2139                 }
2140             }
2141           else
2142             {
2143               /* If the procedure requires an explicit interface, the actual
2144                  argument is passed according to the corresponding formal
2145                  argument.  If the corresponding formal argument is a POINTER,
2146                  ALLOCATABLE or assumed shape, we do not use g77's calling
2147                  convention, and pass the address of the array descriptor
2148                  instead. Otherwise we use g77's calling convention.  */
2149               int f;
2150               f = (fsym != NULL)
2151                   && !(fsym->attr.pointer || fsym->attr.allocatable)
2152                   && fsym->as->type != AS_ASSUMED_SHAPE;
2153               f = f || !sym->attr.always_explicit;
2154
2155               if (e->expr_type == EXPR_VARIABLE
2156                     && is_aliased_array (e))
2157                 /* The actual argument is a component reference to an
2158                    array of derived types.  In this case, the argument
2159                    is converted to a temporary, which is passed and then
2160                    written back after the procedure call.  */
2161                 gfc_conv_aliased_arg (&parmse, e, f,
2162                         fsym ? fsym->attr.intent : INTENT_INOUT);
2163               else
2164                 gfc_conv_array_parameter (&parmse, e, argss, f);
2165
2166               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
2167                  allocated on entry, it must be deallocated.  */
2168               if (fsym && fsym->attr.allocatable
2169                   && fsym->attr.intent == INTENT_OUT)
2170                 {
2171                   tmp = build_fold_indirect_ref (parmse.expr);
2172                   tmp = gfc_trans_dealloc_allocated (tmp);
2173                   gfc_add_expr_to_block (&se->pre, tmp);
2174                 }
2175
2176             } 
2177         }
2178
2179       if (fsym)
2180         {
2181           if (e)
2182             {
2183               /* If an optional argument is itself an optional dummy
2184                  argument, check its presence and substitute a null
2185                  if absent.  */
2186               if (e->expr_type == EXPR_VARIABLE
2187                     && e->symtree->n.sym->attr.optional
2188                     && fsym->attr.optional)
2189                 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2190
2191               /* If an INTENT(OUT) dummy of derived type has a default
2192                  initializer, it must be (re)initialized here.  */
2193               if (fsym->attr.intent == INTENT_OUT
2194                     && fsym->ts.type == BT_DERIVED
2195                     && fsym->value)
2196                 {
2197                   gcc_assert (!fsym->attr.allocatable);
2198                   tmp = gfc_trans_assignment (e, fsym->value, false);
2199                   gfc_add_expr_to_block (&se->pre, tmp);
2200                 }
2201
2202               /* Obtain the character length of an assumed character
2203                  length procedure from the typespec.  */
2204               if (fsym->ts.type == BT_CHARACTER
2205                     && parmse.string_length == NULL_TREE
2206                     && e->ts.type == BT_PROCEDURE
2207                     && e->symtree->n.sym->ts.type == BT_CHARACTER
2208                     && e->symtree->n.sym->ts.cl->length != NULL)
2209                 {
2210                   gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2211                   parmse.string_length
2212                         = e->symtree->n.sym->ts.cl->backend_decl;
2213                 }
2214             }
2215
2216           if (need_interface_mapping)
2217             gfc_add_interface_mapping (&mapping, fsym, &parmse);
2218         }
2219
2220       gfc_add_block_to_block (&se->pre, &parmse.pre);
2221       gfc_add_block_to_block (&post, &parmse.post);
2222
2223       /* Allocated allocatable components of derived types must be
2224          deallocated for INTENT(OUT) dummy arguments and non-variable
2225          scalars.  Non-variable arrays are dealt with in trans-array.c
2226          (gfc_conv_array_parameter).  */
2227       if (e && e->ts.type == BT_DERIVED
2228             && e->ts.derived->attr.alloc_comp
2229             && ((formal && formal->sym->attr.intent == INTENT_OUT)
2230                    ||
2231                 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2232         {
2233           int parm_rank;
2234           tmp = build_fold_indirect_ref (parmse.expr);
2235           parm_rank = e->rank;
2236           switch (parm_kind)
2237             {
2238             case (ELEMENTAL):
2239             case (SCALAR):
2240               parm_rank = 0;
2241               break;
2242
2243             case (SCALAR_POINTER):
2244               tmp = build_fold_indirect_ref (tmp);
2245               break;
2246             case (ARRAY):
2247               tmp = parmse.expr;
2248               break;
2249             }
2250
2251           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2252           if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2253             tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2254                             tmp, build_empty_stmt ());
2255
2256           if (e->expr_type != EXPR_VARIABLE)
2257             /* Don't deallocate non-variables until they have been used.  */
2258             gfc_add_expr_to_block (&se->post, tmp);
2259           else 
2260             {
2261               gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2262               gfc_add_expr_to_block (&se->pre, tmp);
2263             }
2264         }
2265
2266       /* Character strings are passed as two parameters, a length and a
2267          pointer.  */
2268       if (parmse.string_length != NULL_TREE)
2269         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2270
2271       arglist = gfc_chainon_list (arglist, parmse.expr);
2272     }
2273   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2274
2275   ts = sym->ts;
2276   if (ts.type == BT_CHARACTER)
2277     {
2278       if (sym->ts.cl->length == NULL)
2279         {
2280           /* Assumed character length results are not allowed by 5.1.1.5 of the
2281              standard and are trapped in resolve.c; except in the case of SPREAD
2282              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
2283              we take the character length of the first argument for the result.
2284              For dummies, we have to look through the formal argument list for
2285              this function and use the character length found there.*/
2286           if (!sym->attr.dummy)
2287             cl.backend_decl = TREE_VALUE (stringargs);
2288           else
2289             {
2290               formal = sym->ns->proc_name->formal;
2291               for (; formal; formal = formal->next)
2292                 if (strcmp (formal->sym->name, sym->name) == 0)
2293                   cl.backend_decl = formal->sym->ts.cl->backend_decl;
2294             }
2295         }
2296         else
2297         {
2298           tree tmp;
2299
2300           /* Calculate the length of the returned string.  */
2301           gfc_init_se (&parmse, NULL);
2302           if (need_interface_mapping)
2303             gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2304           else
2305             gfc_conv_expr (&parmse, sym->ts.cl->length);
2306           gfc_add_block_to_block (&se->pre, &parmse.pre);
2307           gfc_add_block_to_block (&se->post, &parmse.post);
2308           
2309           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2310           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2311                              build_int_cst (gfc_charlen_type_node, 0));
2312           cl.backend_decl = tmp;
2313         }
2314
2315       /* Set up a charlen structure for it.  */
2316       cl.next = NULL;
2317       cl.length = NULL;
2318       ts.cl = &cl;
2319
2320       len = cl.backend_decl;
2321     }
2322
2323   byref = gfc_return_by_reference (sym);
2324   if (byref)
2325     {
2326       if (se->direct_byref)
2327         {
2328           /* Sometimes, too much indirection can be applied; eg. for
2329              function_result = array_valued_recursive_function.  */
2330           if (TREE_TYPE (TREE_TYPE (se->expr))
2331                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2332                 && GFC_DESCRIPTOR_TYPE_P
2333                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2334             se->expr = build_fold_indirect_ref (se->expr);
2335
2336           retargs = gfc_chainon_list (retargs, se->expr);
2337         }
2338       else if (sym->result->attr.dimension)
2339         {
2340           gcc_assert (se->loop && info);
2341
2342           /* Set the type of the array.  */
2343           tmp = gfc_typenode_for_spec (&ts);
2344           info->dimen = se->loop->dimen;
2345
2346           /* Evaluate the bounds of the result, if known.  */
2347           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2348
2349           /* Create a temporary to store the result.  In case the function
2350              returns a pointer, the temporary will be a shallow copy and
2351              mustn't be deallocated.  */
2352           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2353           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2354                                        false, !sym->attr.pointer, callee_alloc);
2355
2356           /* Pass the temporary as the first argument.  */
2357           tmp = info->descriptor;
2358           tmp = build_fold_addr_expr (tmp);
2359           retargs = gfc_chainon_list (retargs, tmp);
2360         }
2361       else if (ts.type == BT_CHARACTER)
2362         {
2363           /* Pass the string length.  */
2364           type = gfc_get_character_type (ts.kind, ts.cl);
2365           type = build_pointer_type (type);
2366
2367           /* Return an address to a char[0:len-1]* temporary for
2368              character pointers.  */
2369           if (sym->attr.pointer || sym->attr.allocatable)
2370             {
2371               /* Build char[0:len-1] * pstr.  */
2372               tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2373                                  build_int_cst (gfc_charlen_type_node, 1));
2374               tmp = build_range_type (gfc_array_index_type,
2375                                       gfc_index_zero_node, tmp);
2376               tmp = build_array_type (gfc_character1_type_node, tmp);
2377               var = gfc_create_var (build_pointer_type (tmp), "pstr");
2378
2379               /* Provide an address expression for the function arguments.  */
2380               var = build_fold_addr_expr (var);
2381             }
2382           else
2383             var = gfc_conv_string_tmp (se, type, len);
2384
2385           retargs = gfc_chainon_list (retargs, var);
2386         }
2387       else
2388         {
2389           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2390
2391           type = gfc_get_complex_type (ts.kind);
2392           var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2393           retargs = gfc_chainon_list (retargs, var);
2394         }
2395
2396       /* Add the string length to the argument list.  */
2397       if (ts.type == BT_CHARACTER)
2398         retargs = gfc_chainon_list (retargs, len);
2399     }
2400   gfc_free_interface_mapping (&mapping);
2401
2402   /* Add the return arguments.  */
2403   arglist = chainon (retargs, arglist);
2404
2405   /* Add the hidden string length parameters to the arguments.  */
2406   arglist = chainon (arglist, stringargs);
2407
2408   /* We may want to append extra arguments here.  This is used e.g. for
2409      calls to libgfortran_matmul_??, which need extra information.  */
2410   if (append_args != NULL_TREE)
2411     arglist = chainon (arglist, append_args);
2412
2413   /* Generate the actual call.  */
2414   gfc_conv_function_val (se, sym);
2415
2416   /* If there are alternate return labels, function type should be
2417      integer.  Can't modify the type in place though, since it can be shared
2418      with other functions.  For dummy arguments, the typing is done to
2419      to this result, even if it has to be repeated for each call.  */
2420   if (has_alternate_specifier
2421       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2422     {
2423       if (!sym->attr.dummy)
2424         {
2425           TREE_TYPE (sym->backend_decl)
2426                 = build_function_type (integer_type_node,
2427                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2428           se->expr = build_fold_addr_expr (sym->backend_decl);
2429         }
2430       else
2431         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2432     }
2433
2434   fntype = TREE_TYPE (TREE_TYPE (se->expr));
2435   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2436
2437   /* If we have a pointer function, but we don't want a pointer, e.g.
2438      something like
2439         x = f()
2440      where f is pointer valued, we have to dereference the result.  */
2441   if (!se->want_pointer && !byref && sym->attr.pointer)
2442     se->expr = build_fold_indirect_ref (se->expr);
2443
2444   /* f2c calling conventions require a scalar default real function to
2445      return a double precision result.  Convert this back to default
2446      real.  We only care about the cases that can happen in Fortran 77.
2447   */
2448   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2449       && sym->ts.kind == gfc_default_real_kind
2450       && !sym->attr.always_explicit)
2451     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2452
2453   /* A pure function may still have side-effects - it may modify its
2454      parameters.  */
2455   TREE_SIDE_EFFECTS (se->expr) = 1;
2456 #if 0
2457   if (!sym->attr.pure)
2458     TREE_SIDE_EFFECTS (se->expr) = 1;
2459 #endif
2460
2461   if (byref)
2462     {
2463       /* Add the function call to the pre chain.  There is no expression.  */
2464       gfc_add_expr_to_block (&se->pre, se->expr);
2465       se->expr = NULL_TREE;
2466
2467       if (!se->direct_byref)
2468         {
2469           if (sym->attr.dimension)
2470             {
2471               if (flag_bounds_check)
2472                 {
2473                   /* Check the data pointer hasn't been modified.  This would
2474                      happen in a function returning a pointer.  */
2475                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2476                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
2477                                      tmp, info->data);
2478                   gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2479                 }
2480               se->expr = info->descriptor;
2481               /* Bundle in the string length.  */
2482               se->string_length = len;
2483             }
2484           else if (sym->ts.type == BT_CHARACTER)
2485             {
2486               /* Dereference for character pointer results.  */
2487               if (sym->attr.pointer || sym->attr.allocatable)
2488                 se->expr = build_fold_indirect_ref (var);
2489               else
2490                 se->expr = var;
2491
2492               se->string_length = len;
2493             }
2494           else
2495             {
2496               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2497               se->expr = build_fold_indirect_ref (var);
2498             }
2499         }
2500     }
2501
2502   /* Follow the function call with the argument post block.  */
2503   if (byref)
2504     gfc_add_block_to_block (&se->pre, &post);
2505   else
2506     gfc_add_block_to_block (&se->post, &post);
2507
2508   return has_alternate_specifier;
2509 }
2510
2511
2512 /* Generate code to copy a string.  */
2513
2514 static void
2515 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2516                        tree slength, tree src)
2517 {
2518   tree tmp, dlen, slen;
2519   tree dsc;
2520   tree ssc;
2521   tree cond;
2522   tree cond2;
2523   tree tmp2;
2524   tree tmp3;
2525   tree tmp4;
2526   stmtblock_t tempblock;
2527
2528   dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2529   slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2530
2531   /* Deal with single character specially.  */
2532   dsc = gfc_to_single_character (dlen, dest);
2533   ssc = gfc_to_single_character (slen, src);
2534   if (dsc != NULL_TREE && ssc != NULL_TREE)
2535     {
2536       gfc_add_modify_expr (block, dsc, ssc);
2537       return;
2538     }
2539
2540   /* Do nothing if the destination length is zero.  */
2541   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2542                       build_int_cst (gfc_charlen_type_node, 0));
2543
2544   /* The following code was previously in _gfortran_copy_string:
2545
2546        // The two strings may overlap so we use memmove.
2547        void
2548        copy_string (GFC_INTEGER_4 destlen, char * dest,
2549                     GFC_INTEGER_4 srclen, const char * src)
2550        {
2551          if (srclen >= destlen)
2552            {
2553              // This will truncate if too long.
2554              memmove (dest, src, destlen);
2555            }
2556          else
2557            {
2558              memmove (dest, src, srclen);
2559              // Pad with spaces.
2560              memset (&dest[srclen], ' ', destlen - srclen);
2561            }
2562        }
2563
2564      We're now doing it here for better optimization, but the logic
2565      is the same.  */
2566   
2567   /* Truncate string if source is too long.  */
2568   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2569   tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2570                           3, dest, src, dlen);
2571
2572   /* Else copy and pad with spaces.  */
2573   tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2574                           3, dest, src, slen);
2575
2576   tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2577                       fold_convert (pchar_type_node, slen));
2578   tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2579                           tmp4, 
2580                           build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2581                                          lang_hooks.to_target_charset (' ')),
2582                           fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2583                                        dlen, slen));
2584
2585   gfc_init_block (&tempblock);
2586   gfc_add_expr_to_block (&tempblock, tmp3);
2587   gfc_add_expr_to_block (&tempblock, tmp4);
2588   tmp3 = gfc_finish_block (&tempblock);
2589
2590   /* The whole copy_string function is there.  */
2591   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2592   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2593   gfc_add_expr_to_block (block, tmp);
2594 }
2595
2596
2597 /* Translate a statement function.
2598    The value of a statement function reference is obtained by evaluating the
2599    expression using the values of the actual arguments for the values of the
2600    corresponding dummy arguments.  */
2601
2602 static void
2603 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2604 {
2605   gfc_symbol *sym;
2606   gfc_symbol *fsym;
2607   gfc_formal_arglist *fargs;
2608   gfc_actual_arglist *args;
2609   gfc_se lse;
2610   gfc_se rse;
2611   gfc_saved_var *saved_vars;
2612   tree *temp_vars;
2613   tree type;
2614   tree tmp;
2615   int n;
2616
2617   sym = expr->symtree->n.sym;
2618   args = expr->value.function.actual;
2619   gfc_init_se (&lse, NULL);
2620   gfc_init_se (&rse, NULL);
2621
2622   n = 0;
2623   for (fargs = sym->formal; fargs; fargs = fargs->next)
2624     n++;
2625   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2626   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2627
2628   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2629     {
2630       /* Each dummy shall be specified, explicitly or implicitly, to be
2631          scalar.  */
2632       gcc_assert (fargs->sym->attr.dimension == 0);
2633       fsym = fargs->sym;
2634
2635       /* Create a temporary to hold the value.  */
2636       type = gfc_typenode_for_spec (&fsym->ts);
2637       temp_vars[n] = gfc_create_var (type, fsym->name);
2638
2639       if (fsym->ts.type == BT_CHARACTER)
2640         {
2641           /* Copy string arguments.  */
2642           tree arglen;
2643
2644           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2645                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2646
2647           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2648           tmp = gfc_build_addr_expr (build_pointer_type (type),
2649                                      temp_vars[n]);
2650
2651           gfc_conv_expr (&rse, args->expr);
2652           gfc_conv_string_parameter (&rse);
2653           gfc_add_block_to_block (&se->pre, &lse.pre);
2654           gfc_add_block_to_block (&se->pre, &rse.pre);
2655
2656           gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2657                                  rse.expr);
2658           gfc_add_block_to_block (&se->pre, &lse.post);
2659           gfc_add_block_to_block (&se->pre, &rse.post);
2660         }
2661       else
2662         {
2663           /* For everything else, just evaluate the expression.  */
2664           gfc_conv_expr (&lse, args->expr);
2665
2666           gfc_add_block_to_block (&se->pre, &lse.pre);
2667           gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2668           gfc_add_block_to_block (&se->pre, &lse.post);
2669         }
2670
2671       args = args->next;
2672     }
2673
2674   /* Use the temporary variables in place of the real ones.  */
2675   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2676     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2677
2678   gfc_conv_expr (se, sym->value);
2679
2680   if (sym->ts.type == BT_CHARACTER)
2681     {
2682       gfc_conv_const_charlen (sym->ts.cl);
2683
2684       /* Force the expression to the correct length.  */
2685       if (!INTEGER_CST_P (se->string_length)
2686           || tree_int_cst_lt (se->string_length,
2687                               sym->ts.cl->backend_decl))
2688         {
2689           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2690           tmp = gfc_create_var (type, sym->name);
2691           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2692           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2693                                  se->string_length, se->expr);
2694           se->expr = tmp;
2695         }
2696       se->string_length = sym->ts.cl->backend_decl;
2697     }
2698
2699   /* Restore the original variables.  */
2700   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2701     gfc_restore_sym (fargs->sym, &saved_vars[n]);
2702   gfc_free (saved_vars);
2703 }
2704
2705
2706 /* Translate a function expression.  */
2707
2708 static void
2709 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2710 {
2711   gfc_symbol *sym;
2712
2713   if (expr->value.function.isym)
2714     {
2715       gfc_conv_intrinsic_function (se, expr);
2716       return;
2717     }
2718
2719   /* We distinguish statement functions from general functions to improve
2720      runtime performance.  */
2721   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2722     {
2723       gfc_conv_statement_function (se, expr);
2724       return;
2725     }
2726
2727   /* expr.value.function.esym is the resolved (specific) function symbol for
2728      most functions.  However this isn't set for dummy procedures.  */
2729   sym = expr->value.function.esym;
2730   if (!sym)
2731     sym = expr->symtree->n.sym;
2732   gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2733 }
2734
2735
2736 static void
2737 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2738 {
2739   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2740   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2741
2742   gfc_conv_tmp_array_ref (se);
2743   gfc_advance_se_ss_chain (se);
2744 }
2745
2746
2747 /* Build a static initializer.  EXPR is the expression for the initial value.
2748    The other parameters describe the variable of the component being 
2749    initialized. EXPR may be null.  */
2750
2751 tree
2752 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2753                       bool array, bool pointer)
2754 {
2755   gfc_se se;
2756
2757   if (!(expr || pointer))
2758     return NULL_TREE;
2759
2760   if (array)
2761     {
2762       /* Arrays need special handling.  */
2763       if (pointer)
2764         return gfc_build_null_descriptor (type);
2765       else
2766         return gfc_conv_array_initializer (type, expr);
2767     }
2768   else if (pointer)
2769     return fold_convert (type, null_pointer_node);
2770   else
2771     {
2772       switch (ts->type)
2773         {
2774         case BT_DERIVED:
2775           gfc_init_se (&se, NULL);
2776           gfc_conv_structure (&se, expr, 1);
2777           return se.expr;
2778
2779         case BT_CHARACTER:
2780           return gfc_conv_string_init (ts->cl->backend_decl,expr);
2781
2782         default:
2783           gfc_init_se (&se, NULL);
2784           gfc_conv_constant (&se, expr);
2785           return se.expr;
2786         }
2787     }
2788 }
2789   
2790 static tree
2791 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2792 {
2793   gfc_se rse;
2794   gfc_se lse;
2795   gfc_ss *rss;
2796   gfc_ss *lss;
2797   stmtblock_t body;
2798   stmtblock_t block;
2799   gfc_loopinfo loop;
2800   int n;
2801   tree tmp;
2802
2803   gfc_start_block (&block);
2804
2805   /* Initialize the scalarizer.  */
2806   gfc_init_loopinfo (&loop);
2807
2808   gfc_init_se (&lse, NULL);
2809   gfc_init_se (&rse, NULL);
2810
2811   /* Walk the rhs.  */
2812   rss = gfc_walk_expr (expr);
2813   if (rss == gfc_ss_terminator)
2814     {
2815       /* The rhs is scalar.  Add a ss for the expression.  */
2816       rss = gfc_get_ss ();
2817       rss->next = gfc_ss_terminator;
2818       rss->type = GFC_SS_SCALAR;
2819       rss->expr = expr;
2820     }
2821
2822   /* Create a SS for the destination.  */
2823   lss = gfc_get_ss ();
2824   lss->type = GFC_SS_COMPONENT;
2825   lss->expr = NULL;
2826   lss->shape = gfc_get_shape (cm->as->rank);
2827   lss->next = gfc_ss_terminator;
2828   lss->data.info.dimen = cm->as->rank;
2829   lss->data.info.descriptor = dest;
2830   lss->data.info.data = gfc_conv_array_data (dest);
2831   lss->data.info.offset = gfc_conv_array_offset (dest);
2832   for (n = 0; n < cm->as->rank; n++)
2833     {
2834       lss->data.info.dim[n] = n;
2835       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2836       lss->data.info.stride[n] = gfc_index_one_node;
2837
2838       mpz_init (lss->shape[n]);
2839       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2840                cm->as->lower[n]->value.integer);
2841       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2842     }
2843   
2844   /* Associate the SS with the loop.  */
2845   gfc_add_ss_to_loop (&loop, lss);
2846   gfc_add_ss_to_loop (&loop, rss);
2847
2848   /* Calculate the bounds of the scalarization.  */
2849   gfc_conv_ss_startstride (&loop);
2850
2851   /* Setup the scalarizing loops.  */
2852   gfc_conv_loop_setup (&loop);
2853
2854   /* Setup the gfc_se structures.  */
2855   gfc_copy_loopinfo_to_se (&lse, &loop);
2856   gfc_copy_loopinfo_to_se (&rse, &loop);
2857
2858   rse.ss = rss;
2859   gfc_mark_ss_chain_used (rss, 1);
2860   lse.ss = lss;
2861   gfc_mark_ss_chain_used (lss, 1);
2862
2863   /* Start the scalarized loop body.  */
2864   gfc_start_scalarized_body (&loop, &body);
2865
2866   gfc_conv_tmp_array_ref (&lse);
2867   if (cm->ts.type == BT_CHARACTER)
2868     lse.string_length = cm->ts.cl->backend_decl;
2869
2870   gfc_conv_expr (&rse, expr);
2871
2872   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2873   gfc_add_expr_to_block (&body, tmp);
2874
2875   gcc_assert (rse.ss == gfc_ss_terminator);
2876
2877   /* Generate the copying loops.  */
2878   gfc_trans_scalarizing_loops (&loop, &body);
2879
2880   /* Wrap the whole thing up.  */
2881   gfc_add_block_to_block (&block, &loop.pre);
2882   gfc_add_block_to_block (&block, &loop.post);
2883
2884   for (n = 0; n < cm->as->rank; n++)
2885     mpz_clear (lss->shape[n]);
2886   gfc_free (lss->shape);
2887
2888   gfc_cleanup_loop (&loop);
2889
2890   return gfc_finish_block (&block);
2891 }
2892
2893
2894 /* Assign a single component of a derived type constructor.  */
2895
2896 static tree
2897 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2898 {
2899   gfc_se se;
2900   gfc_se lse;
2901   gfc_ss *rss;
2902   stmtblock_t block;
2903   tree tmp;
2904   tree offset;
2905   int n;
2906
2907   gfc_start_block (&block);
2908
2909   if (cm->pointer)
2910     {
2911       gfc_init_se (&se, NULL);
2912       /* Pointer component.  */
2913       if (cm->dimension)
2914         {
2915           /* Array pointer.  */
2916           if (expr->expr_type == EXPR_NULL)
2917             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2918           else
2919             {
2920               rss = gfc_walk_expr (expr);
2921               se.direct_byref = 1;
2922               se.expr = dest;
2923               gfc_conv_expr_descriptor (&se, expr, rss);
2924               gfc_add_block_to_block (&block, &se.pre);
2925               gfc_add_block_to_block (&block, &se.post);
2926             }
2927         }
2928       else
2929         {
2930           /* Scalar pointers.  */
2931           se.want_pointer = 1;
2932           gfc_conv_expr (&se, expr);
2933           gfc_add_block_to_block (&block, &se.pre);
2934           gfc_add_modify_expr (&block, dest,
2935                                fold_convert (TREE_TYPE (dest), se.expr));
2936           gfc_add_block_to_block (&block, &se.post);
2937         }
2938     }
2939   else if (cm->dimension)
2940     {
2941       if (cm->allocatable && expr->expr_type == EXPR_NULL)
2942         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2943       else if (cm->allocatable)
2944         {
2945           tree tmp2;
2946
2947           gfc_init_se (&se, NULL);
2948  
2949           rss = gfc_walk_expr (expr);
2950           se.want_pointer = 0;
2951           gfc_conv_expr_descriptor (&se, expr, rss);
2952           gfc_add_block_to_block (&block, &se.pre);
2953
2954           tmp = fold_convert (TREE_TYPE (dest), se.expr);
2955           gfc_add_modify_expr (&block, dest, tmp);
2956
2957           if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2958             tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2959                                        cm->as->rank);
2960           else
2961             tmp = gfc_duplicate_allocatable (dest, se.expr,
2962                                              TREE_TYPE(cm->backend_decl),
2963                                              cm->as->rank);
2964
2965           gfc_add_expr_to_block (&block, tmp);
2966
2967           gfc_add_block_to_block (&block, &se.post);
2968           gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2969
2970           /* Shift the lbound and ubound of temporaries to being unity, rather
2971              than zero, based.  Calculate the offset for all cases.  */
2972           offset = gfc_conv_descriptor_offset (dest);
2973           gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2974           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2975           for (n = 0; n < expr->rank; n++)
2976             {
2977               if (expr->expr_type != EXPR_VARIABLE
2978                   && expr->expr_type != EXPR_CONSTANT)
2979                 {
2980                   tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2981                   gfc_add_modify_expr (&block, tmp,
2982                                        fold_build2 (PLUS_EXPR,
2983                                                     gfc_array_index_type,
2984                                                     tmp, gfc_index_one_node));
2985                   tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2986                   gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2987                 }
2988               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2989                                  gfc_conv_descriptor_lbound (dest,
2990                                                              gfc_rank_cst[n]),
2991                                  gfc_conv_descriptor_stride (dest,
2992                                                              gfc_rank_cst[n]));
2993               gfc_add_modify_expr (&block, tmp2, tmp);
2994               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2995               gfc_add_modify_expr (&block, offset, tmp);
2996             }
2997         }
2998       else
2999         {
3000           tmp = gfc_trans_subarray_assign (dest, cm, expr);
3001           gfc_add_expr_to_block (&block, tmp);
3002         }
3003     }
3004   else if (expr->ts.type == BT_DERIVED)
3005     {
3006       if (expr->expr_type != EXPR_STRUCTURE)
3007         {
3008           gfc_init_se (&se, NULL);
3009           gfc_conv_expr (&se, expr);
3010           gfc_add_modify_expr (&block, dest,
3011                                fold_convert (TREE_TYPE (dest), se.expr));
3012         }
3013       else
3014         {
3015           /* Nested constructors.  */
3016           tmp = gfc_trans_structure_assign (dest, expr);
3017           gfc_add_expr_to_block (&block, tmp);
3018         }
3019     }
3020   else
3021     {
3022       /* Scalar component.  */
3023       gfc_init_se (&se, NULL);
3024       gfc_init_se (&lse, NULL);
3025
3026       gfc_conv_expr (&se, expr);
3027       if (cm->ts.type == BT_CHARACTER)
3028         lse.string_length = cm->ts.cl->backend_decl;
3029       lse.expr = dest;
3030       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3031       gfc_add_expr_to_block (&block, tmp);
3032     }
3033   return gfc_finish_block (&block);
3034 }
3035
3036 /* Assign a derived type constructor to a variable.  */
3037
3038 static tree
3039 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3040 {
3041   gfc_constructor *c;
3042   gfc_component *cm;
3043   stmtblock_t block;
3044   tree field;
3045   tree tmp;
3046
3047   gfc_start_block (&block);
3048   cm = expr->ts.derived->components;
3049   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3050     {
3051       /* Skip absent members in default initializers.  */
3052       if (!c->expr)
3053         continue;
3054
3055       field = cm->backend_decl;
3056       tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3057       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3058       gfc_add_expr_to_block (&block, tmp);
3059     }
3060   return gfc_finish_block (&block);
3061 }
3062
3063 /* Build an expression for a constructor. If init is nonzero then
3064    this is part of a static variable initializer.  */
3065
3066 void
3067 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3068 {
3069   gfc_constructor *c;
3070   gfc_component *cm;
3071   tree val;
3072   tree type;
3073   tree tmp;
3074   VEC(constructor_elt,gc) *v = NULL;
3075
3076   gcc_assert (se->ss == NULL);
3077   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3078   type = gfc_typenode_for_spec (&expr->ts);
3079
3080   if (!init)
3081     {
3082       /* Create a temporary variable and fill it in.  */
3083       se->expr = gfc_create_var (type, expr->ts.derived->name);
3084       tmp = gfc_trans_structure_assign (se->expr, expr);
3085       gfc_add_expr_to_block (&se->pre, tmp);
3086       return;
3087     }
3088
3089   cm = expr->ts.derived->components;
3090
3091   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3092     {
3093       /* Skip absent members in default initializers and allocatable
3094          components.  Although the latter have a default initializer
3095          of EXPR_NULL,... by default, the static nullify is not needed
3096          since this is done every time we come into scope.  */
3097       if (!c->expr || cm->allocatable)
3098         continue;
3099
3100       val = gfc_conv_initializer (c->expr, &cm->ts,
3101           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3102
3103       /* Append it to the constructor list.  */
3104       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3105     }
3106   se->expr = build_constructor (type, v);
3107 }
3108
3109
3110 /* Translate a substring expression.  */
3111
3112 static void
3113 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3114 {
3115   gfc_ref *ref;
3116
3117   ref = expr->ref;
3118
3119   gcc_assert (ref->type == REF_SUBSTRING);
3120
3121   se->expr = gfc_build_string_const(expr->value.character.length,
3122                                     expr->value.character.string);
3123   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3124   TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3125
3126   gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3127 }
3128
3129
3130 /* Entry point for expression translation.  Evaluates a scalar quantity.
3131    EXPR is the expression to be translated, and SE is the state structure if
3132    called from within the scalarized.  */
3133
3134 void
3135 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3136 {
3137   if (se->ss && se->ss->expr == expr
3138       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3139     {
3140       /* Substitute a scalar expression evaluated outside the scalarization
3141          loop.  */
3142       se->expr = se->ss->data.scalar.expr;
3143       se->string_length = se->ss->string_length;
3144       gfc_advance_se_ss_chain (se);
3145       return;
3146     }
3147
3148   switch (expr->expr_type)
3149     {
3150     case EXPR_OP:
3151       gfc_conv_expr_op (se, expr);
3152       break;
3153
3154     case EXPR_FUNCTION:
3155       gfc_conv_function_expr (se, expr);
3156       break;
3157
3158     case EXPR_CONSTANT:
3159       gfc_conv_constant (se, expr);
3160       break;
3161
3162     case EXPR_VARIABLE:
3163       gfc_conv_variable (se, expr);
3164       break;
3165
3166     case EXPR_NULL:
3167       se->expr = null_pointer_node;
3168       break;
3169
3170     case EXPR_SUBSTRING:
3171       gfc_conv_substring_expr (se, expr);
3172       break;
3173
3174     case EXPR_STRUCTURE:
3175       gfc_conv_structure (se, expr, 0);
3176       break;
3177
3178     case EXPR_ARRAY:
3179       gfc_conv_array_constructor_expr (se, expr);
3180       break;
3181
3182     default:
3183       gcc_unreachable ();
3184       break;
3185     }
3186 }
3187
3188 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3189    of an assignment.  */
3190 void
3191 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3192 {
3193   gfc_conv_expr (se, expr);
3194   /* All numeric lvalues should have empty post chains.  If not we need to
3195      figure out a way of rewriting an lvalue so that it has no post chain.  */
3196   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3197 }
3198
3199 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3200    numeric expressions.  Used for scalar values where inserting cleanup code
3201    is inconvenient.  */
3202 void
3203 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3204 {
3205   tree val;
3206
3207   gcc_assert (expr->ts.type != BT_CHARACTER);
3208   gfc_conv_expr (se, expr);
3209   if (se->post.head)
3210     {
3211       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3212       gfc_add_modify_expr (&se->pre, val, se->expr);
3213       se->expr = val;
3214       gfc_add_block_to_block (&se->pre, &se->post);
3215     }
3216 }
3217
3218 /* Helper to translate and expression and convert it to a particular type.  */
3219 void
3220 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3221 {
3222   gfc_conv_expr_val (se, expr);
3223   se->expr = convert (type, se->expr);
3224 }
3225
3226
3227 /* Converts an expression so that it can be passed by reference.  Scalar
3228    values only.  */
3229
3230 void
3231 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3232 {
3233   tree var;
3234
3235   if (se->ss && se->ss->expr == expr
3236       && se->ss->type == GFC_SS_REFERENCE)
3237     {
3238       se->expr = se->ss->data.scalar.expr;
3239       se->string_length = se->ss->string_length;
3240       gfc_advance_se_ss_chain (se);
3241       return;
3242     }
3243
3244   if (expr->ts.type == BT_CHARACTER)
3245     {
3246       gfc_conv_expr (se, expr);
3247       gfc_conv_string_parameter (se);
3248       return;
3249     }
3250
3251   if (expr->expr_type == EXPR_VARIABLE)
3252     {
3253       se->want_pointer = 1;
3254       gfc_conv_expr (se, expr);
3255       if (se->post.head)
3256         {
3257           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3258           gfc_add_modify_expr (&se->pre, var, se->expr);
3259           gfc_add_block_to_block (&se->pre, &se->post);
3260           se->expr = var;
3261         }
3262       return;
3263     }
3264
3265   gfc_conv_expr (se, expr);
3266
3267   /* Create a temporary var to hold the value.  */
3268   if (TREE_CONSTANT (se->expr))
3269     {
3270       tree tmp = se->expr;
3271       STRIP_TYPE_NOPS (tmp);
3272       var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3273       DECL_INITIAL (var) = tmp;
3274       TREE_STATIC (var) = 1;
3275       pushdecl (var);
3276     }
3277   else
3278     {
3279       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3280       gfc_add_modify_expr (&se->pre, var, se->expr);
3281     }
3282   gfc_add_block_to_block (&se->pre, &se->post);
3283
3284   /* Take the address of that value.  */
3285   se->expr = build_fold_addr_expr (var);
3286 }
3287
3288
3289 tree
3290 gfc_trans_pointer_assign (gfc_code * code)
3291 {
3292   return gfc_trans_pointer_assignment (code->expr, code->expr2);
3293 }
3294
3295
3296 /* Generate code for a pointer assignment.  */
3297
3298 tree
3299 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3300 {
3301   gfc_se lse;
3302   gfc_se rse;
3303   gfc_ss *lss;
3304   gfc_ss *rss;
3305   stmtblock_t block;
3306   tree desc;
3307   tree tmp;
3308
3309   gfc_start_block (&block);
3310
3311   gfc_init_se (&lse, NULL);
3312
3313   lss = gfc_walk_expr (expr1);
3314   rss = gfc_walk_expr (expr2);
3315   if (lss == gfc_ss_terminator)
3316     {
3317       /* Scalar pointers.  */
3318       lse.want_pointer = 1;
3319       gfc_conv_expr (&lse, expr1);
3320       gcc_assert (rss == gfc_ss_terminator);
3321       gfc_init_se (&rse, NULL);
3322       rse.want_pointer = 1;
3323       gfc_conv_expr (&rse, expr2);
3324       gfc_add_block_to_block (&block, &lse.pre);
3325       gfc_add_block_to_block (&block, &rse.pre);
3326       gfc_add_modify_expr (&block, lse.expr,
3327                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3328       gfc_add_block_to_block (&block, &rse.post);
3329       gfc_add_block_to_block (&block, &lse.post);
3330     }
3331   else
3332     {
3333       /* Array pointer.  */
3334       gfc_conv_expr_descriptor (&lse, expr1, lss);
3335       switch (expr2->expr_type)
3336         {
3337         case EXPR_NULL:
3338           /* Just set the data pointer to null.  */
3339           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3340           break;
3341
3342         case EXPR_VARIABLE:
3343           /* Assign directly to the pointer's descriptor.  */
3344           lse.direct_byref = 1;
3345           gfc_conv_expr_descriptor (&lse, expr2, rss);
3346           break;
3347
3348         default:
3349           /* Assign to a temporary descriptor and then copy that
3350              temporary to the pointer.  */
3351           desc = lse.expr;
3352           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3353
3354           lse.expr = tmp;
3355           lse.direct_byref = 1;
3356           gfc_conv_expr_descriptor (&lse, expr2, rss);
3357           gfc_add_modify_expr (&lse.pre, desc, tmp);
3358           break;
3359         }
3360       gfc_add_block_to_block (&block, &lse.pre);
3361       gfc_add_block_to_block (&block, &lse.post);
3362     }
3363   return gfc_finish_block (&block);
3364 }
3365
3366
3367 /* Makes sure se is suitable for passing as a function string parameter.  */
3368 /* TODO: Need to check all callers fo this function.  It may be abused.  */
3369
3370 void
3371 gfc_conv_string_parameter (gfc_se * se)
3372 {
3373   tree type;
3374
3375   if (TREE_CODE (se->expr) == STRING_CST)
3376     {
3377       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3378       return;
3379     }
3380
3381   type = TREE_TYPE (se->expr);
3382   if (TYPE_STRING_FLAG (type))
3383     {
3384       gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3385       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3386     }
3387
3388   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3389   gcc_assert (se->string_length
3390           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3391 }
3392
3393
3394 /* Generate code for assignment of scalar variables.  Includes character
3395    strings and derived types with allocatable components.  */
3396
3397 tree
3398 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3399                          bool l_is_temp, bool r_is_var)
3400 {
3401   stmtblock_t block;
3402   tree tmp;
3403   tree cond;
3404
3405   gfc_init_block (&block);
3406
3407   if (ts.type == BT_CHARACTER)
3408     {
3409       gcc_assert (lse->string_length != NULL_TREE
3410               && rse->string_length != NULL_TREE);
3411
3412       gfc_conv_string_parameter (lse);
3413       gfc_conv_string_parameter (rse);
3414
3415       gfc_add_block_to_block (&block, &lse->pre);
3416       gfc_add_block_to_block (&block, &rse->pre);
3417
3418       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3419                              rse->string_length, rse->expr);
3420     }
3421   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3422     {
3423       cond = NULL_TREE;
3424         
3425       /* Are the rhs and the lhs the same?  */
3426       if (r_is_var)
3427         {
3428           cond = fold_build2 (EQ_EXPR, boolean_type_node,
3429                               build_fold_addr_expr (lse->expr),
3430                               build_fold_addr_expr (rse->expr));
3431           cond = gfc_evaluate_now (cond, &lse->pre);
3432         }
3433
3434       /* Deallocate the lhs allocated components as long as it is not
3435          the same as the rhs.  */
3436       if (!l_is_temp)
3437         {
3438           tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3439           if (r_is_var)
3440             tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3441           gfc_add_expr_to_block (&lse->pre, tmp);
3442         }
3443         
3444       gfc_add_block_to_block (&block, &lse->pre);
3445       gfc_add_block_to_block (&block, &rse->pre);
3446
3447       gfc_add_modify_expr (&block, lse->expr,
3448                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
3449
3450       /* Do a deep copy if the rhs is a variable, if it is not the
3451          same as the lhs.  */
3452       if (r_is_var)
3453         {
3454           tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3455           tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3456           gfc_add_expr_to_block (&block, tmp);
3457         }
3458     }
3459   else
3460     {
3461       gfc_add_block_to_block (&block, &lse->pre);
3462       gfc_add_block_to_block (&block, &rse->pre);
3463
3464       gfc_add_modify_expr (&block, lse->expr,
3465                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
3466     }
3467
3468   gfc_add_block_to_block (&block, &lse->post);
3469   gfc_add_block_to_block (&block, &rse->post);
3470
3471   return gfc_finish_block (&block);
3472 }
3473
3474
3475 /* Try to translate array(:) = func (...), where func is a transformational
3476    array function, without using a temporary.  Returns NULL is this isn't the
3477    case.  */
3478
3479 static tree
3480 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3481 {
3482   gfc_se se;
3483   gfc_ss *ss;
3484   gfc_ref * ref;
3485   bool seen_array_ref;
3486
3487   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
3488   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3489     return NULL;
3490
3491   /* Elemental functions don't need a temporary anyway.  */
3492   if (expr2->value.function.esym != NULL
3493       && expr2->value.function.esym->attr.elemental)
3494     return NULL;
3495
3496   /* Fail if EXPR1 can't be expressed as a descriptor.  */
3497   if (gfc_ref_needs_temporary_p (expr1->ref))
3498     return NULL;
3499
3500   /* Functions returning pointers need temporaries.  */
3501   if (expr2->symtree->n.sym->attr.pointer 
3502       || expr2->symtree->n.sym->attr.allocatable)
3503     return NULL;
3504
3505   /* Character array functions need temporaries unless the
3506      character lengths are the same.  */
3507   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3508     {
3509       if (expr1->ts.cl->length == NULL
3510             || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3511         return NULL;
3512
3513       if (expr2->ts.cl->length == NULL
3514             || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3515         return NULL;
3516
3517       if (mpz_cmp (expr1->ts.cl->length->value.integer,
3518                      expr2->ts.cl->length->value.integer) != 0)
3519         return NULL;
3520     }
3521
3522   /* Check that no LHS component references appear during an array
3523      reference. This is needed because we do not have the means to
3524      span any arbitrary stride with an array descriptor. This check
3525      is not needed for the rhs because the function result has to be
3526      a complete type.  */
3527   seen_array_ref = false;
3528   for (ref = expr1->ref; ref; ref = ref->next)
3529     {
3530       if (ref->type == REF_ARRAY)
3531         seen_array_ref= true;
3532       else if (ref->type == REF_COMPONENT && seen_array_ref)
3533         return NULL;
3534     }
3535
3536   /* Check for a dependency.  */
3537   if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3538                                    expr2->value.function.esym,
3539                                    expr2->value.function.actual))
3540     return NULL;
3541
3542   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3543      functions.  */
3544   gcc_assert (expr2->value.function.isym
3545               || (gfc_return_by_reference (expr2->value.function.esym)
3546               && expr2->value.function.esym->result->attr.dimension));
3547
3548   ss = gfc_walk_expr (expr1);
3549   gcc_assert (ss != gfc_ss_terminator);
3550   gfc_init_se (&se, NULL);
3551   gfc_start_block (&se.pre);
3552   se.want_pointer = 1;
3553
3554   gfc_conv_array_parameter (&se, expr1, ss, 0);
3555
3556   se.direct_byref = 1;
3557   se.ss = gfc_walk_expr (expr2);
3558   gcc_assert (se.ss != gfc_ss_terminator);
3559   gfc_conv_function_expr (&se, expr2);
3560   gfc_add_block_to_block (&se.pre, &se.post);
3561
3562   return gfc_finish_block (&se.pre);
3563 }
3564
3565 /* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
3566
3567 static bool
3568 is_zero_initializer_p (gfc_expr * expr)
3569 {
3570   if (expr->expr_type != EXPR_CONSTANT)
3571     return false;
3572   /* We ignore Hollerith constants for the time being.  */
3573   if (expr->from_H)
3574     return false;
3575
3576   switch (expr->ts.type)
3577     {
3578     case BT_INTEGER:
3579       return mpz_cmp_si (expr->value.integer, 0) == 0;
3580
3581     case BT_REAL:
3582       return mpfr_zero_p (expr->value.real)
3583              && MPFR_SIGN (expr->value.real) >= 0;
3584
3585     case BT_LOGICAL:
3586       return expr->value.logical == 0;
3587
3588     case BT_COMPLEX:
3589       return mpfr_zero_p (expr->value.complex.r)
3590              && MPFR_SIGN (expr->value.complex.r) >= 0
3591              && mpfr_zero_p (expr->value.complex.i)
3592              && MPFR_SIGN (expr->value.complex.i) >= 0;
3593
3594     default:
3595       break;
3596     }
3597   return false;
3598 }
3599
3600 /* Try to efficiently translate array(:) = 0.  Return NULL if this
3601    can't be done.  */
3602
3603 static tree
3604 gfc_trans_zero_assign (gfc_expr * expr)
3605 {
3606   tree dest, len, type;
3607   tree tmp;
3608   gfc_symbol *sym;
3609
3610   sym = expr->symtree->n.sym;
3611   dest = gfc_get_symbol_decl (sym);
3612
3613   type = TREE_TYPE (dest);
3614   if (POINTER_TYPE_P (type))
3615     type = TREE_TYPE (type);
3616   if (!GFC_ARRAY_TYPE_P (type))
3617     return NULL_TREE;
3618
3619   /* Determine the length of the array.  */
3620   len = GFC_TYPE_ARRAY_SIZE (type);
3621   if (!len || TREE_CODE (len) != INTEGER_CST)
3622     return NULL_TREE;
3623
3624   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3625                      TYPE_SIZE_UNIT (gfc_get_element_type (type)));
3626
3627   /* Convert arguments to the correct types.  */
3628   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3629     dest = gfc_build_addr_expr (pvoid_type_node, dest);
3630   else
3631     dest = fold_convert (pvoid_type_node, dest);
3632   len = fold_convert (size_type_node, len);
3633
3634   /* Construct call to __builtin_memset.  */
3635   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3636                          3, dest, integer_zero_node, len);
3637   return fold_convert (void_type_node, tmp);
3638 }
3639
3640
3641 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3642    that constructs the call to __builtin_memcpy.  */
3643
3644 static tree
3645 gfc_build_memcpy_call (tree dst, tree src, tree len)
3646 {
3647   tree tmp;
3648
3649   /* Convert arguments to the correct types.  */
3650   if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3651     dst = gfc_build_addr_expr (pvoid_type_node, dst);
3652   else
3653     dst = fold_convert (pvoid_type_node, dst);
3654
3655   if (!POINTER_TYPE_P (TREE_TYPE (src)))
3656     src = gfc_build_addr_expr (pvoid_type_node, src);
3657   else
3658     src = fold_convert (pvoid_type_node, src);
3659
3660   len = fold_convert (size_type_node, len);
3661
3662   /* Construct call to __builtin_memcpy.  */
3663   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3664   return fold_convert (void_type_node, tmp);
3665 }
3666
3667
3668 /* Try to efficiently translate dst(:) = src(:).  Return NULL if this
3669    can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
3670    source/rhs, both are gfc_full_array_ref_p which have been checked for
3671    dependencies.  */
3672
3673 static tree
3674 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3675 {
3676   tree dst, dlen, dtype;
3677   tree src, slen, stype;
3678
3679   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3680   src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3681
3682   dtype = TREE_TYPE (dst);
3683   if (POINTER_TYPE_P (dtype))
3684     dtype = TREE_TYPE (dtype);
3685   stype = TREE_TYPE (src);
3686   if (POINTER_TYPE_P (stype))
3687     stype = TREE_TYPE (stype);
3688
3689   if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3690     return NULL_TREE;
3691
3692   /* Determine the lengths of the arrays.  */
3693   dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3694   if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3695     return NULL_TREE;
3696   dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3697                       TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3698
3699   slen = GFC_TYPE_ARRAY_SIZE (stype);
3700   if (!slen || TREE_CODE (slen) != INTEGER_CST)
3701     return NULL_TREE;
3702   slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3703                       TYPE_SIZE_UNIT (gfc_get_element_type (stype)));
3704
3705   /* Sanity check that they are the same.  This should always be
3706      the case, as we should already have checked for conformance.  */
3707   if (!tree_int_cst_equal (slen, dlen))
3708     return NULL_TREE;
3709
3710   return gfc_build_memcpy_call (dst, src, dlen);
3711 }
3712
3713
3714 /* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
3715    this can't be done.  EXPR1 is the destination/lhs for which
3716    gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
3717
3718 static tree
3719 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3720 {
3721   unsigned HOST_WIDE_INT nelem;
3722   tree dst, dtype;
3723   tree src, stype;
3724   tree len;
3725
3726   nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3727   if (nelem == 0)
3728     return NULL_TREE;
3729
3730   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3731   dtype = TREE_TYPE (dst);
3732   if (POINTER_TYPE_P (dtype))
3733     dtype = TREE_TYPE (dtype);
3734   if (!GFC_ARRAY_TYPE_P (dtype))
3735     return NULL_TREE;
3736
3737   /* Determine the lengths of the array.  */
3738   len = GFC_TYPE_ARRAY_SIZE (dtype);
3739   if (!len || TREE_CODE (len) != INTEGER_CST)
3740     return NULL_TREE;
3741
3742   /* Confirm that the constructor is the same size.  */
3743   if (compare_tree_int (len, nelem) != 0)
3744     return NULL_TREE;
3745
3746   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3747                      TYPE_SIZE_UNIT (gfc_get_element_type (dtype)));
3748
3749   stype = gfc_typenode_for_spec (&expr2->ts);
3750   src = gfc_build_constant_array_constructor (expr2, stype);
3751
3752   stype = TREE_TYPE (src);
3753   if (POINTER_TYPE_P (stype))
3754     stype = TREE_TYPE (stype);
3755
3756   return gfc_build_memcpy_call (dst, src, len);
3757 }
3758
3759
3760 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3761    assignment.  EXPR1 is the destination/RHS and EXPR2 is the source/LHS.  */
3762
3763 static tree
3764 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3765 {
3766   gfc_se lse;
3767   gfc_se rse;
3768   gfc_ss *lss;
3769   gfc_ss *lss_section;
3770   gfc_ss *rss;
3771   gfc_loopinfo loop;
3772   tree tmp;
3773   stmtblock_t block;
3774   stmtblock_t body;
3775   bool l_is_temp;
3776
3777   /* Assignment of the form lhs = rhs.  */
3778   gfc_start_block (&block);
3779
3780   gfc_init_se (&lse, NULL);
3781   gfc_init_se (&rse, NULL);
3782
3783   /* Walk the lhs.  */
3784   lss = gfc_walk_expr (expr1);
3785   rss = NULL;
3786   if (lss != gfc_ss_terminator)
3787     {
3788       /* The assignment needs scalarization.  */
3789       lss_section = lss;
3790
3791       /* Find a non-scalar SS from the lhs.  */
3792       while (lss_section != gfc_ss_terminator
3793              && lss_section->type != GFC_SS_SECTION)
3794         lss_section = lss_section->next;
3795
3796       gcc_assert (lss_section != gfc_ss_terminator);
3797
3798       /* Initialize the scalarizer.  */
3799       gfc_init_loopinfo (&loop);
3800
3801       /* Walk the rhs.  */
3802       rss = gfc_walk_expr (expr2);
3803       if (rss == gfc_ss_terminator)
3804         {
3805           /* The rhs is scalar.  Add a ss for the expression.  */
3806           rss = gfc_get_ss ();
3807           rss->next = gfc_ss_terminator;
3808           rss->type = GFC_SS_SCALAR;
3809           rss->expr = expr2;
3810         }
3811       /* Associate the SS with the loop.  */
3812       gfc_add_ss_to_loop (&loop, lss);
3813       gfc_add_ss_to_loop (&loop, rss);
3814
3815       /* Calculate the bounds of the scalarization.  */
3816       gfc_conv_ss_startstride (&loop);
3817       /* Resolve any data dependencies in the statement.  */
3818       gfc_conv_resolve_dependencies (&loop, lss, rss);
3819       /* Setup the scalarizing loops.  */
3820       gfc_conv_loop_setup (&loop);
3821
3822       /* Setup the gfc_se structures.  */
3823       gfc_copy_loopinfo_to_se (&lse, &loop);
3824       gfc_copy_loopinfo_to_se (&rse, &loop);
3825
3826       rse.ss = rss;
3827       gfc_mark_ss_chain_used (rss, 1);
3828       if (loop.temp_ss == NULL)
3829         {
3830           lse.ss = lss;
3831           gfc_mark_ss_chain_used (lss, 1);
3832         }
3833       else
3834         {
3835           lse.ss = loop.temp_ss;
3836           gfc_mark_ss_chain_used (lss, 3);
3837           gfc_mark_ss_chain_used (loop.temp_ss, 3);
3838         }
3839
3840       /* Start the scalarized loop body.  */
3841       gfc_start_scalarized_body (&loop, &body);
3842     }
3843   else
3844     gfc_init_block (&body);
3845
3846   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3847
3848   /* Translate the expression.  */
3849   gfc_conv_expr (&rse, expr2);
3850
3851   if (l_is_temp)
3852     {
3853       gfc_conv_tmp_array_ref (&lse);
3854       gfc_advance_se_ss_chain (&lse);
3855     }
3856   else
3857     gfc_conv_expr (&lse, expr1);
3858
3859   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3860                                  l_is_temp || init_flag,
3861                                  expr2->expr_type == EXPR_VARIABLE);
3862   gfc_add_expr_to_block (&body, tmp);
3863
3864   if (lss == gfc_ss_terminator)
3865     {
3866       /* Use the scalar assignment as is.  */
3867       gfc_add_block_to_block (&block, &body);
3868     }
3869   else
3870     {
3871       gcc_assert (lse.ss == gfc_ss_terminator
3872                   && rse.ss == gfc_ss_terminator);
3873
3874       if (l_is_temp)
3875         {
3876           gfc_trans_scalarized_loop_boundary (&loop, &body);
3877
3878           /* We need to copy the temporary to the actual lhs.  */
3879           gfc_init_se (&lse, NULL);
3880           gfc_init_se (&rse, NULL);
3881           gfc_copy_loopinfo_to_se (&lse, &loop);
3882           gfc_copy_loopinfo_to_se (&rse, &loop);
3883
3884           rse.ss = loop.temp_ss;
3885           lse.ss = lss;
3886
3887           gfc_conv_tmp_array_ref (&rse);
3888           gfc_advance_se_ss_chain (&rse);
3889           gfc_conv_expr (&lse, expr1);
3890
3891           gcc_assert (lse.ss == gfc_ss_terminator
3892                       && rse.ss == gfc_ss_terminator);
3893
3894           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3895                                          false, false);
3896           gfc_add_expr_to_block (&body, tmp);
3897         }
3898
3899       /* Generate the copying loops.  */
3900       gfc_trans_scalarizing_loops (&loop, &body);
3901
3902       /* Wrap the whole thing up.  */
3903       gfc_add_block_to_block (&block, &loop.pre);
3904       gfc_add_block_to_block (&block, &loop.post);
3905
3906       gfc_cleanup_loop (&loop);
3907     }
3908
3909   return gfc_finish_block (&block);
3910 }
3911
3912
3913 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array.  */
3914
3915 static bool
3916 copyable_array_p (gfc_expr * expr)
3917 {
3918   /* First check it's an array.  */
3919   if (expr->rank < 1 || !expr->ref)
3920     return false;
3921
3922   /* Next check that it's of a simple enough type.  */
3923   switch (expr->ts.type)
3924     {
3925     case BT_INTEGER:
3926     case BT_REAL:
3927     case BT_COMPLEX:
3928     case BT_LOGICAL:
3929       return true;
3930
3931     case BT_CHARACTER:
3932       return false;
3933
3934     case BT_DERIVED:
3935       return !expr->ts.derived->attr.alloc_comp;
3936
3937     default:
3938       break;
3939     }
3940
3941   return false;
3942 }
3943
3944 /* Translate an assignment.  */
3945
3946 tree
3947 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3948 {
3949   tree tmp;
3950
3951   /* Special case a single function returning an array.  */
3952   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3953     {
3954       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3955       if (tmp)
3956         return tmp;
3957     }
3958
3959   /* Special case assigning an array to zero.  */
3960   if (expr1->expr_type == EXPR_VARIABLE
3961       && expr1->rank > 0
3962       && expr1->ref
3963       && expr1->ref->next == NULL
3964       && gfc_full_array_ref_p (expr1->ref)
3965       && is_zero_initializer_p (expr2))
3966     {
3967       tmp = gfc_trans_zero_assign (expr1);
3968       if (tmp)
3969         return tmp;
3970     }
3971
3972   /* Special case copying one array to another.  */
3973   if (expr1->expr_type == EXPR_VARIABLE
3974       && copyable_array_p (expr1)
3975       && gfc_full_array_ref_p (expr1->ref)
3976       && expr2->expr_type == EXPR_VARIABLE
3977       && copyable_array_p (expr2)
3978       && gfc_full_array_ref_p (expr2->ref)
3979       && gfc_compare_types (&expr1->ts, &expr2->ts)
3980       && !gfc_check_dependency (expr1, expr2, 0))
3981     {
3982       tmp = gfc_trans_array_copy (expr1, expr2);
3983       if (tmp)
3984         return tmp;
3985     }
3986
3987   /* Special case initializing an array from a constant array constructor.  */
3988   if (expr1->expr_type == EXPR_VARIABLE
3989       && copyable_array_p (expr1)
3990       && gfc_full_array_ref_p (expr1->ref)
3991       && expr2->expr_type == EXPR_ARRAY
3992       && gfc_compare_types (&expr1->ts, &expr2->ts))
3993     {
3994       tmp = gfc_trans_array_constructor_copy (expr1, expr2);
3995       if (tmp)
3996         return tmp;
3997     }
3998
3999   /* Fallback to the scalarizer to generate explicit loops.  */
4000   return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4001 }
4002
4003 tree
4004 gfc_trans_init_assign (gfc_code * code)
4005 {
4006   return gfc_trans_assignment (code->expr, code->expr2, true);
4007 }
4008
4009 tree
4010 gfc_trans_assign (gfc_code * code)
4011 {
4012   return gfc_trans_assignment (code->expr, code->expr2, false);
4013 }