OSDN Git Service

4dc4d56b3565fbe3e4a1f7b09f3a3c743b32c832
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c
1 /* Expression translation
2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Paul Brook <paul@nowt.org>
4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr.  */
24
25 #include "config.h"
26 #include "system.h"
27 #include "coretypes.h"
28 #include "tree.h"
29 #include "convert.h"
30 #include "ggc.h"
31 #include "toplev.h"
32 #include "real.h"
33 #include "tree-gimple.h"
34 #include "flags.h"
35 #include "gfortran.h"
36 #include "trans.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
41 #include "trans-stmt.h"
42 #include "dependency.h"
43
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
46                                                  gfc_expr *);
47
48 /* Copy the scalarization loop variables.  */
49
50 static void
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
52 {
53   dest->ss = src->ss;
54   dest->loop = src->loop;
55 }
56
57
58 /* Initialize a simple expression holder.
59
60    Care must be taken when multiple se are created with the same parent.
61    The child se must be kept in sync.  The easiest way is to delay creation
62    of a child se until after after the previous se has been translated.  */
63
64 void
65 gfc_init_se (gfc_se * se, gfc_se * parent)
66 {
67   memset (se, 0, sizeof (gfc_se));
68   gfc_init_block (&se->pre);
69   gfc_init_block (&se->post);
70
71   se->parent = parent;
72
73   if (parent)
74     gfc_copy_se_loopvars (se, parent);
75 }
76
77
78 /* Advances to the next SS in the chain.  Use this rather than setting
79    se->ss = se->ss->next because all the parents needs to be kept in sync.
80    See gfc_init_se.  */
81
82 void
83 gfc_advance_se_ss_chain (gfc_se * se)
84 {
85   gfc_se *p;
86
87   gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
88
89   p = se;
90   /* Walk down the parent chain.  */
91   while (p != NULL)
92     {
93       /* Simple consistency check.  */
94       gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
95
96       p->ss = p->ss->next;
97
98       p = p->parent;
99     }
100 }
101
102
103 /* Ensures the result of the expression as either a temporary variable
104    or a constant so that it can be used repeatedly.  */
105
106 void
107 gfc_make_safe_expr (gfc_se * se)
108 {
109   tree var;
110
111   if (CONSTANT_CLASS_P (se->expr))
112     return;
113
114   /* We need a temporary for this result.  */
115   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116   gfc_add_modify_expr (&se->pre, var, se->expr);
117   se->expr = var;
118 }
119
120
121 /* Return an expression which determines if a dummy parameter is present.
122    Also used for arguments to procedures with multiple entry points.  */
123
124 tree
125 gfc_conv_expr_present (gfc_symbol * sym)
126 {
127   tree decl;
128
129   gcc_assert (sym->attr.dummy);
130
131   decl = gfc_get_symbol_decl (sym);
132   if (TREE_CODE (decl) != PARM_DECL)
133     {
134       /* Array parameters use a temporary descriptor, we want the real
135          parameter.  */
136       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
139     }
140   return build2 (NE_EXPR, boolean_type_node, decl,
141                  fold_convert (TREE_TYPE (decl), null_pointer_node));
142 }
143
144
145 /* Get the character length of an expression, looking through gfc_refs
146    if necessary.  */
147
148 tree
149 gfc_get_expr_charlen (gfc_expr *e)
150 {
151   gfc_ref *r;
152   tree length;
153
154   gcc_assert (e->expr_type == EXPR_VARIABLE 
155               && e->ts.type == BT_CHARACTER);
156   
157   length = NULL; /* To silence compiler warning.  */
158
159   /* First candidate: if the variable is of type CHARACTER, the
160      expression's length could be the length of the character
161      variable.  */
162   if (e->symtree->n.sym->ts.type == BT_CHARACTER)
163     length = e->symtree->n.sym->ts.cl->backend_decl;
164
165   /* Look through the reference chain for component references.  */
166   for (r = e->ref; r; r = r->next)
167     {
168       switch (r->type)
169         {
170         case REF_COMPONENT:
171           if (r->u.c.component->ts.type == BT_CHARACTER)
172             length = r->u.c.component->ts.cl->backend_decl;
173           break;
174
175         case REF_ARRAY:
176           /* Do nothing.  */
177           break;
178
179         default:
180           /* We should never got substring references here.  These will be
181              broken down by the scalarizer.  */
182           gcc_unreachable ();
183         }
184     }
185
186   gcc_assert (length != NULL);
187   return length;
188 }
189
190   
191
192 /* Generate code to initialize a string length variable. Returns the
193    value.  */
194
195 void
196 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
197 {
198   gfc_se se;
199   tree tmp;
200
201   gfc_init_se (&se, NULL);
202   gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
203   gfc_add_block_to_block (pblock, &se.pre);
204
205   tmp = cl->backend_decl;
206   gfc_add_modify_expr (pblock, tmp, se.expr);
207 }
208
209
210 static void
211 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
212 {
213   tree tmp;
214   tree type;
215   tree var;
216   gfc_se start;
217   gfc_se end;
218
219   type = gfc_get_character_type (kind, ref->u.ss.length);
220   type = build_pointer_type (type);
221
222   var = NULL_TREE;
223   gfc_init_se (&start, se);
224   gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
225   gfc_add_block_to_block (&se->pre, &start.pre);
226
227   if (integer_onep (start.expr))
228     gfc_conv_string_parameter (se);
229   else
230     {
231       /* Change the start of the string.  */
232       if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
233         tmp = se->expr;
234       else
235         tmp = gfc_build_indirect_ref (se->expr);
236       tmp = gfc_build_array_ref (tmp, start.expr);
237       se->expr = gfc_build_addr_expr (type, tmp);
238     }
239
240   /* Length = end + 1 - start.  */
241   gfc_init_se (&end, se);
242   if (ref->u.ss.end == NULL)
243     end.expr = se->string_length;
244   else
245     {
246       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
247       gfc_add_block_to_block (&se->pre, &end.pre);
248     }
249   tmp =
250     build2 (MINUS_EXPR, gfc_charlen_type_node,
251             fold_convert (gfc_charlen_type_node, integer_one_node),
252             start.expr);
253   tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
254   se->string_length = fold (tmp);
255 }
256
257
258 /* Convert a derived type component reference.  */
259
260 static void
261 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
262 {
263   gfc_component *c;
264   tree tmp;
265   tree decl;
266   tree field;
267
268   c = ref->u.c.component;
269
270   gcc_assert (c->backend_decl);
271
272   field = c->backend_decl;
273   gcc_assert (TREE_CODE (field) == FIELD_DECL);
274   decl = se->expr;
275   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
276
277   se->expr = tmp;
278
279   if (c->ts.type == BT_CHARACTER)
280     {
281       tmp = c->ts.cl->backend_decl;
282       /* Components must always be constant length.  */
283       gcc_assert (tmp && INTEGER_CST_P (tmp));
284       se->string_length = tmp;
285     }
286
287   if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
288     se->expr = gfc_build_indirect_ref (se->expr);
289 }
290
291
292 /* Return the contents of a variable. Also handles reference/pointer
293    variables (all Fortran pointer references are implicit).  */
294
295 static void
296 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
297 {
298   gfc_ref *ref;
299   gfc_symbol *sym;
300
301   sym = expr->symtree->n.sym;
302   if (se->ss != NULL)
303     {
304       /* Check that something hasn't gone horribly wrong.  */
305       gcc_assert (se->ss != gfc_ss_terminator);
306       gcc_assert (se->ss->expr == expr);
307
308       /* A scalarized term.  We already know the descriptor.  */
309       se->expr = se->ss->data.info.descriptor;
310       se->string_length = se->ss->string_length;
311       for (ref = se->ss->data.info.ref; ref; ref = ref->next)
312         if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
313           break;
314     }
315   else
316     {
317       tree se_expr = NULL_TREE;
318
319       /* Handle Cray Pointees.  */
320       if (sym->attr.cray_pointee)
321         se->expr = gfc_conv_cray_pointee (sym);
322       else
323         se->expr = gfc_get_symbol_decl (sym);
324
325       /* Special case for assigning the return value of a function.
326          Self recursive functions must have an explicit return value.  */
327       if (se->expr == current_function_decl && sym->attr.function
328           && (sym->result == sym))
329         se_expr = gfc_get_fake_result_decl (sym);
330
331       /* Similarly for alternate entry points.  */
332       else if (sym->attr.function && sym->attr.entry
333                && (sym->result == sym)
334                && sym->ns->proc_name->backend_decl == current_function_decl)
335         {
336           gfc_entry_list *el = NULL;
337
338           for (el = sym->ns->entries; el; el = el->next)
339             if (sym == el->sym)
340               {
341                 se_expr = gfc_get_fake_result_decl (sym);
342                 break;
343               }
344         }
345
346       else if (sym->attr.result
347                && sym->ns->proc_name->backend_decl == current_function_decl
348                && sym->ns->proc_name->attr.entry_master
349                && !gfc_return_by_reference (sym->ns->proc_name))
350         se_expr = gfc_get_fake_result_decl (sym);
351
352       if (se_expr)
353         se->expr = se_expr;
354
355       /* Procedure actual arguments.  */
356       else if (sym->attr.flavor == FL_PROCEDURE
357                && se->expr != current_function_decl)
358         {
359           gcc_assert (se->want_pointer);
360           if (!sym->attr.dummy)
361             {
362               gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
363               se->expr = gfc_build_addr_expr (NULL, se->expr);
364             }
365           return;
366         }
367
368
369       /* Dereference the expression, where needed. Since characters
370          are entirely different from other types, they are treated 
371          separately.  */
372       if (sym->ts.type == BT_CHARACTER)
373         {
374           /* Dereference character pointer dummy arguments
375              or results.  */
376           if ((sym->attr.pointer || sym->attr.allocatable)
377               && (sym->attr.dummy
378                   || sym->attr.function
379                   || sym->attr.result))
380             se->expr = gfc_build_indirect_ref (se->expr);
381         }
382       else
383         {
384           /* Dereference non-character scalar dummy arguments.  */
385           if (sym->attr.dummy && !sym->attr.dimension)
386             se->expr = gfc_build_indirect_ref (se->expr);
387
388           /* Dereference scalar hidden result.  */
389           if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
390               && (sym->attr.function || sym->attr.result)
391               && !sym->attr.dimension && !sym->attr.pointer)
392             se->expr = gfc_build_indirect_ref (se->expr);
393
394           /* Dereference non-character pointer variables. 
395              These must be dummies, results, or scalars.  */
396           if ((sym->attr.pointer || sym->attr.allocatable)
397               && (sym->attr.dummy
398                   || sym->attr.function
399                   || sym->attr.result
400                   || !sym->attr.dimension))
401             se->expr = gfc_build_indirect_ref (se->expr);
402         }
403
404       ref = expr->ref;
405     }
406
407   /* For character variables, also get the length.  */
408   if (sym->ts.type == BT_CHARACTER)
409     {
410       se->string_length = sym->ts.cl->backend_decl;
411       gcc_assert (se->string_length);
412     }
413
414   while (ref)
415     {
416       switch (ref->type)
417         {
418         case REF_ARRAY:
419           /* Return the descriptor if that's what we want and this is an array
420              section reference.  */
421           if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
422             return;
423 /* TODO: Pointers to single elements of array sections, eg elemental subs.  */
424           /* Return the descriptor for array pointers and allocations.  */
425           if (se->want_pointer
426               && ref->next == NULL && (se->descriptor_only))
427             return;
428
429           gfc_conv_array_ref (se, &ref->u.ar);
430           /* Return a pointer to an element.  */
431           break;
432
433         case REF_COMPONENT:
434           gfc_conv_component_ref (se, ref);
435           break;
436
437         case REF_SUBSTRING:
438           gfc_conv_substring (se, ref, expr->ts.kind);
439           break;
440
441         default:
442           gcc_unreachable ();
443           break;
444         }
445       ref = ref->next;
446     }
447   /* Pointer assignment, allocation or pass by reference.  Arrays are handled
448      separately.  */
449   if (se->want_pointer)
450     {
451       if (expr->ts.type == BT_CHARACTER)
452         gfc_conv_string_parameter (se);
453       else 
454         se->expr = gfc_build_addr_expr (NULL, se->expr);
455     }
456 }
457
458
459 /* Unary ops are easy... Or they would be if ! was a valid op.  */
460
461 static void
462 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
463 {
464   gfc_se operand;
465   tree type;
466
467   gcc_assert (expr->ts.type != BT_CHARACTER);
468   /* Initialize the operand.  */
469   gfc_init_se (&operand, se);
470   gfc_conv_expr_val (&operand, expr->value.op.op1);
471   gfc_add_block_to_block (&se->pre, &operand.pre);
472
473   type = gfc_typenode_for_spec (&expr->ts);
474
475   /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
476      We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
477      All other unary operators have an equivalent GIMPLE unary operator.  */
478   if (code == TRUTH_NOT_EXPR)
479     se->expr = build2 (EQ_EXPR, type, operand.expr,
480                        convert (type, integer_zero_node));
481   else
482     se->expr = build1 (code, type, operand.expr);
483
484 }
485
486 /* Expand power operator to optimal multiplications when a value is raised
487    to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
488    Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
489    Programming", 3rd Edition, 1998.  */
490
491 /* This code is mostly duplicated from expand_powi in the backend.
492    We establish the "optimal power tree" lookup table with the defined size.
493    The items in the table are the exponents used to calculate the index
494    exponents. Any integer n less than the value can get an "addition chain",
495    with the first node being one.  */
496 #define POWI_TABLE_SIZE 256
497
498 /* The table is from builtins.c.  */
499 static const unsigned char powi_table[POWI_TABLE_SIZE] =
500   {
501       0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
502       4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
503       8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
504      12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
505      16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
506      20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
507      24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
508      28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
509      32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
510      36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
511      40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
512      44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
513      48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
514      52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
515      56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
516      60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
517      64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
518      68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
519      72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
520      76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
521      80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
522      84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
523      88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
524      92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
525      96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
526     100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
527     104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
528     108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
529     112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
530     116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
531     120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
532     124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
533   };
534
535 /* If n is larger than lookup table's max index, we use the "window 
536    method".  */
537 #define POWI_WINDOW_SIZE 3
538
539 /* Recursive function to expand the power operator. The temporary 
540    values are put in tmpvar. The function returns tmpvar[1] ** n.  */
541 static tree
542 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
543 {
544   tree op0;
545   tree op1;
546   tree tmp;
547   int digit;
548
549   if (n < POWI_TABLE_SIZE)
550     {
551       if (tmpvar[n])
552         return tmpvar[n];
553
554       op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
555       op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
556     }
557   else if (n & 1)
558     {
559       digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
560       op0 = gfc_conv_powi (se, n - digit, tmpvar);
561       op1 = gfc_conv_powi (se, digit, tmpvar);
562     }
563   else
564     {
565       op0 = gfc_conv_powi (se, n >> 1, tmpvar);
566       op1 = op0;
567     }
568
569   tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
570   tmp = gfc_evaluate_now (tmp, &se->pre);
571
572   if (n < POWI_TABLE_SIZE)
573     tmpvar[n] = tmp;
574
575   return tmp;
576 }
577
578
579 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
580    return 1. Else return 0 and a call to runtime library functions
581    will have to be built.  */
582 static int
583 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
584 {
585   tree cond;
586   tree tmp;
587   tree type;
588   tree vartmp[POWI_TABLE_SIZE];
589   int n;
590   int sgn;
591
592   type = TREE_TYPE (lhs);
593   n = abs (TREE_INT_CST_LOW (rhs));
594   sgn = tree_int_cst_sgn (rhs);
595
596   if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
597       && (n > 2 || n < -1))
598     return 0;
599
600   /* rhs == 0  */
601   if (sgn == 0)
602     {
603       se->expr = gfc_build_const (type, integer_one_node);
604       return 1;
605     }
606   /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
607   if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
608     {
609       tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
610                     fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
611       cond = build2 (EQ_EXPR, boolean_type_node, lhs,
612                      convert (TREE_TYPE (lhs), integer_one_node));
613
614       /* If rhs is even,
615          result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
616       if ((n & 1) == 0)
617         {
618           tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
619           se->expr = build3 (COND_EXPR, type, tmp,
620                              convert (type, integer_one_node),
621                              convert (type, integer_zero_node));
622           return 1;
623         }
624       /* If rhs is odd,
625          result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
626       tmp = build3 (COND_EXPR, type, tmp,
627                     convert (type, integer_minus_one_node),
628                     convert (type, integer_zero_node));
629       se->expr = build3 (COND_EXPR, type, cond,
630                          convert (type, integer_one_node),
631                          tmp);
632       return 1;
633     }
634
635   memset (vartmp, 0, sizeof (vartmp));
636   vartmp[1] = lhs;
637   if (sgn == -1)
638     {
639       tmp = gfc_build_const (type, integer_one_node);
640       vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
641     }
642
643   se->expr = gfc_conv_powi (se, n, vartmp);
644
645   return 1;
646 }
647
648
649 /* Power op (**).  Constant integer exponent has special handling.  */
650
651 static void
652 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
653 {
654   tree gfc_int4_type_node;
655   int kind;
656   int ikind;
657   gfc_se lse;
658   gfc_se rse;
659   tree fndecl;
660   tree tmp;
661
662   gfc_init_se (&lse, se);
663   gfc_conv_expr_val (&lse, expr->value.op.op1);
664   lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
665   gfc_add_block_to_block (&se->pre, &lse.pre);
666
667   gfc_init_se (&rse, se);
668   gfc_conv_expr_val (&rse, expr->value.op.op2);
669   gfc_add_block_to_block (&se->pre, &rse.pre);
670
671   if (expr->value.op.op2->ts.type == BT_INTEGER
672          && expr->value.op.op2->expr_type == EXPR_CONSTANT)
673     if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
674       return;        
675
676   gfc_int4_type_node = gfc_get_int_type (4);
677
678   kind = expr->value.op.op1->ts.kind;
679   switch (expr->value.op.op2->ts.type)
680     {
681     case BT_INTEGER:
682       ikind = expr->value.op.op2->ts.kind;
683       switch (ikind)
684         {
685         case 1:
686         case 2:
687           rse.expr = convert (gfc_int4_type_node, rse.expr);
688           /* Fall through.  */
689
690         case 4:
691           ikind = 0;
692           break;
693           
694         case 8:
695           ikind = 1;
696           break;
697
698         case 16:
699           ikind = 2;
700           break;
701
702         default:
703           gcc_unreachable ();
704         }
705       switch (kind)
706         {
707         case 1:
708         case 2:
709           if (expr->value.op.op1->ts.type == BT_INTEGER)
710             lse.expr = convert (gfc_int4_type_node, lse.expr);
711           else
712             gcc_unreachable ();
713           /* Fall through.  */
714
715         case 4:
716           kind = 0;
717           break;
718           
719         case 8:
720           kind = 1;
721           break;
722
723         case 10:
724           kind = 2;
725           break;
726
727         case 16:
728           kind = 3;
729           break;
730
731         default:
732           gcc_unreachable ();
733         }
734       
735       switch (expr->value.op.op1->ts.type)
736         {
737         case BT_INTEGER:
738           if (kind == 3) /* Case 16 was not handled properly above.  */
739             kind = 2;
740           fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
741           break;
742
743         case BT_REAL:
744           fndecl = gfor_fndecl_math_powi[kind][ikind].real;
745           break;
746
747         case BT_COMPLEX:
748           fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
749           break;
750
751         default:
752           gcc_unreachable ();
753         }
754       break;
755
756     case BT_REAL:
757       switch (kind)
758         {
759         case 4:
760           fndecl = built_in_decls[BUILT_IN_POWF];
761           break;
762         case 8:
763           fndecl = built_in_decls[BUILT_IN_POW];
764           break;
765         case 10:
766         case 16:
767           fndecl = built_in_decls[BUILT_IN_POWL];
768           break;
769         default:
770           gcc_unreachable ();
771         }
772       break;
773
774     case BT_COMPLEX:
775       switch (kind)
776         {
777         case 4:
778           fndecl = gfor_fndecl_math_cpowf;
779           break;
780         case 8:
781           fndecl = gfor_fndecl_math_cpow;
782           break;
783         case 10:
784           fndecl = gfor_fndecl_math_cpowl10;
785           break;
786         case 16:
787           fndecl = gfor_fndecl_math_cpowl16;
788           break;
789         default:
790           gcc_unreachable ();
791         }
792       break;
793
794     default:
795       gcc_unreachable ();
796       break;
797     }
798
799   tmp = gfc_chainon_list (NULL_TREE, lse.expr);
800   tmp = gfc_chainon_list (tmp, rse.expr);
801   se->expr = fold (gfc_build_function_call (fndecl, tmp));
802 }
803
804
805 /* Generate code to allocate a string temporary.  */
806
807 tree
808 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
809 {
810   tree var;
811   tree tmp;
812   tree args;
813
814   gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
815
816   if (gfc_can_put_var_on_stack (len))
817     {
818       /* Create a temporary variable to hold the result.  */
819       tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
820                          convert (gfc_charlen_type_node, integer_one_node));
821       tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
822       tmp = build_array_type (gfc_character1_type_node, tmp);
823       var = gfc_create_var (tmp, "str");
824       var = gfc_build_addr_expr (type, var);
825     }
826   else
827     {
828       /* Allocate a temporary to hold the result.  */
829       var = gfc_create_var (type, "pstr");
830       args = gfc_chainon_list (NULL_TREE, len);
831       tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
832       tmp = convert (type, tmp);
833       gfc_add_modify_expr (&se->pre, var, tmp);
834
835       /* Free the temporary afterwards.  */
836       tmp = convert (pvoid_type_node, var);
837       args = gfc_chainon_list (NULL_TREE, tmp);
838       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
839       gfc_add_expr_to_block (&se->post, tmp);
840     }
841
842   return var;
843 }
844
845
846 /* Handle a string concatenation operation.  A temporary will be allocated to
847    hold the result.  */
848
849 static void
850 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
851 {
852   gfc_se lse;
853   gfc_se rse;
854   tree len;
855   tree type;
856   tree var;
857   tree args;
858   tree tmp;
859
860   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
861           && expr->value.op.op2->ts.type == BT_CHARACTER);
862
863   gfc_init_se (&lse, se);
864   gfc_conv_expr (&lse, expr->value.op.op1);
865   gfc_conv_string_parameter (&lse);
866   gfc_init_se (&rse, se);
867   gfc_conv_expr (&rse, expr->value.op.op2);
868   gfc_conv_string_parameter (&rse);
869
870   gfc_add_block_to_block (&se->pre, &lse.pre);
871   gfc_add_block_to_block (&se->pre, &rse.pre);
872
873   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
874   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
875   if (len == NULL_TREE)
876     {
877       len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
878                          lse.string_length, rse.string_length);
879     }
880
881   type = build_pointer_type (type);
882
883   var = gfc_conv_string_tmp (se, type, len);
884
885   /* Do the actual concatenation.  */
886   args = NULL_TREE;
887   args = gfc_chainon_list (args, len);
888   args = gfc_chainon_list (args, var);
889   args = gfc_chainon_list (args, lse.string_length);
890   args = gfc_chainon_list (args, lse.expr);
891   args = gfc_chainon_list (args, rse.string_length);
892   args = gfc_chainon_list (args, rse.expr);
893   tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
894   gfc_add_expr_to_block (&se->pre, tmp);
895
896   /* Add the cleanup for the operands.  */
897   gfc_add_block_to_block (&se->pre, &rse.post);
898   gfc_add_block_to_block (&se->pre, &lse.post);
899
900   se->expr = var;
901   se->string_length = len;
902 }
903
904
905 /* Translates an op expression. Common (binary) cases are handled by this
906    function, others are passed on. Recursion is used in either case.
907    We use the fact that (op1.ts == op2.ts) (except for the power
908    operator **).
909    Operators need no special handling for scalarized expressions as long as
910    they call gfc_conv_simple_val to get their operands.
911    Character strings get special handling.  */
912
913 static void
914 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
915 {
916   enum tree_code code;
917   gfc_se lse;
918   gfc_se rse;
919   tree type;
920   tree tmp;
921   int lop;
922   int checkstring;
923
924   checkstring = 0;
925   lop = 0;
926   switch (expr->value.op.operator)
927     {
928     case INTRINSIC_UPLUS:
929       gfc_conv_expr (se, expr->value.op.op1);
930       return;
931
932     case INTRINSIC_UMINUS:
933       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
934       return;
935
936     case INTRINSIC_NOT:
937       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
938       return;
939
940     case INTRINSIC_PLUS:
941       code = PLUS_EXPR;
942       break;
943
944     case INTRINSIC_MINUS:
945       code = MINUS_EXPR;
946       break;
947
948     case INTRINSIC_TIMES:
949       code = MULT_EXPR;
950       break;
951
952     case INTRINSIC_DIVIDE:
953       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
954          an integer, we must round towards zero, so we use a
955          TRUNC_DIV_EXPR.  */
956       if (expr->ts.type == BT_INTEGER)
957         code = TRUNC_DIV_EXPR;
958       else
959         code = RDIV_EXPR;
960       break;
961
962     case INTRINSIC_POWER:
963       gfc_conv_power_op (se, expr);
964       return;
965
966     case INTRINSIC_CONCAT:
967       gfc_conv_concat_op (se, expr);
968       return;
969
970     case INTRINSIC_AND:
971       code = TRUTH_ANDIF_EXPR;
972       lop = 1;
973       break;
974
975     case INTRINSIC_OR:
976       code = TRUTH_ORIF_EXPR;
977       lop = 1;
978       break;
979
980       /* EQV and NEQV only work on logicals, but since we represent them
981          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
982     case INTRINSIC_EQ:
983     case INTRINSIC_EQV:
984       code = EQ_EXPR;
985       checkstring = 1;
986       lop = 1;
987       break;
988
989     case INTRINSIC_NE:
990     case INTRINSIC_NEQV:
991       code = NE_EXPR;
992       checkstring = 1;
993       lop = 1;
994       break;
995
996     case INTRINSIC_GT:
997       code = GT_EXPR;
998       checkstring = 1;
999       lop = 1;
1000       break;
1001
1002     case INTRINSIC_GE:
1003       code = GE_EXPR;
1004       checkstring = 1;
1005       lop = 1;
1006       break;
1007
1008     case INTRINSIC_LT:
1009       code = LT_EXPR;
1010       checkstring = 1;
1011       lop = 1;
1012       break;
1013
1014     case INTRINSIC_LE:
1015       code = LE_EXPR;
1016       checkstring = 1;
1017       lop = 1;
1018       break;
1019
1020     case INTRINSIC_USER:
1021     case INTRINSIC_ASSIGN:
1022       /* These should be converted into function calls by the frontend.  */
1023       gcc_unreachable ();
1024
1025     default:
1026       fatal_error ("Unknown intrinsic op");
1027       return;
1028     }
1029
1030   /* The only exception to this is **, which is handled separately anyway.  */
1031   gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1032
1033   if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1034     checkstring = 0;
1035
1036   /* lhs */
1037   gfc_init_se (&lse, se);
1038   gfc_conv_expr (&lse, expr->value.op.op1);
1039   gfc_add_block_to_block (&se->pre, &lse.pre);
1040
1041   /* rhs */
1042   gfc_init_se (&rse, se);
1043   gfc_conv_expr (&rse, expr->value.op.op2);
1044   gfc_add_block_to_block (&se->pre, &rse.pre);
1045
1046   /* For string comparisons we generate a library call, and compare the return
1047      value with 0.  */
1048   if (checkstring)
1049     {
1050       gfc_conv_string_parameter (&lse);
1051       gfc_conv_string_parameter (&rse);
1052       tmp = NULL_TREE;
1053       tmp = gfc_chainon_list (tmp, lse.string_length);
1054       tmp = gfc_chainon_list (tmp, lse.expr);
1055       tmp = gfc_chainon_list (tmp, rse.string_length);
1056       tmp = gfc_chainon_list (tmp, rse.expr);
1057
1058       /* Build a call for the comparison.  */
1059       lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1060       gfc_add_block_to_block (&lse.post, &rse.post);
1061
1062       rse.expr = integer_zero_node;
1063     }
1064
1065   type = gfc_typenode_for_spec (&expr->ts);
1066
1067   if (lop)
1068     {
1069       /* The result of logical ops is always boolean_type_node.  */
1070       tmp = fold_build2 (code, type, lse.expr, rse.expr);
1071       se->expr = convert (type, tmp);
1072     }
1073   else
1074     se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1075
1076   /* Add the post blocks.  */
1077   gfc_add_block_to_block (&se->post, &rse.post);
1078   gfc_add_block_to_block (&se->post, &lse.post);
1079 }
1080
1081
1082 static void
1083 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1084 {
1085   tree tmp;
1086
1087   if (sym->attr.dummy)
1088     {
1089       tmp = gfc_get_symbol_decl (sym);
1090       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1091               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1092     }
1093   else
1094     {
1095       if (!sym->backend_decl)
1096         sym->backend_decl = gfc_get_extern_function_decl (sym);
1097
1098       tmp = sym->backend_decl;
1099       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1100         {
1101           gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1102           tmp = gfc_build_addr_expr (NULL, tmp);
1103         }
1104     }
1105   se->expr = tmp;
1106 }
1107
1108
1109 /* Initialize MAPPING.  */
1110
1111 void
1112 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1113 {
1114   mapping->syms = NULL;
1115   mapping->charlens = NULL;
1116 }
1117
1118
1119 /* Free all memory held by MAPPING (but not MAPPING itself).  */
1120
1121 void
1122 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1123 {
1124   gfc_interface_sym_mapping *sym;
1125   gfc_interface_sym_mapping *nextsym;
1126   gfc_charlen *cl;
1127   gfc_charlen *nextcl;
1128
1129   for (sym = mapping->syms; sym; sym = nextsym)
1130     {
1131       nextsym = sym->next;
1132       gfc_free_symbol (sym->new->n.sym);
1133       gfc_free (sym->new);
1134       gfc_free (sym);
1135     }
1136   for (cl = mapping->charlens; cl; cl = nextcl)
1137     {
1138       nextcl = cl->next;
1139       gfc_free_expr (cl->length);
1140       gfc_free (cl);
1141     }
1142 }
1143
1144
1145 /* Return a copy of gfc_charlen CL.  Add the returned structure to
1146    MAPPING so that it will be freed by gfc_free_interface_mapping.  */
1147
1148 static gfc_charlen *
1149 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1150                                    gfc_charlen * cl)
1151 {
1152   gfc_charlen *new;
1153
1154   new = gfc_get_charlen ();
1155   new->next = mapping->charlens;
1156   new->length = gfc_copy_expr (cl->length);
1157
1158   mapping->charlens = new;
1159   return new;
1160 }
1161
1162
1163 /* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
1164    array variable that can be used as the actual argument for dummy
1165    argument SYM.  Add any initialization code to BLOCK.  PACKED is as
1166    for gfc_get_nodesc_array_type and DATA points to the first element
1167    in the passed array.  */
1168
1169 static tree
1170 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1171                                  int packed, tree data)
1172 {
1173   tree type;
1174   tree var;
1175
1176   type = gfc_typenode_for_spec (&sym->ts);
1177   type = gfc_get_nodesc_array_type (type, sym->as, packed);
1178
1179   var = gfc_create_var (type, "parm");
1180   gfc_add_modify_expr (block, var, fold_convert (type, data));
1181
1182   return var;
1183 }
1184
1185
1186 /* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
1187    and offset of descriptorless array type TYPE given that it has the same
1188    size as DESC.  Add any set-up code to BLOCK.  */
1189
1190 static void
1191 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1192 {
1193   int n;
1194   tree dim;
1195   tree offset;
1196   tree tmp;
1197
1198   offset = gfc_index_zero_node;
1199   for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1200     {
1201       GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1202       if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1203         {
1204           dim = gfc_rank_cst[n];
1205           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1206                              gfc_conv_descriptor_ubound (desc, dim),
1207                              gfc_conv_descriptor_lbound (desc, dim));
1208           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1209                              GFC_TYPE_ARRAY_LBOUND (type, n),
1210                              tmp);
1211           tmp = gfc_evaluate_now (tmp, block);
1212           GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1213         }
1214       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1215                          GFC_TYPE_ARRAY_LBOUND (type, n),
1216                          GFC_TYPE_ARRAY_STRIDE (type, n));
1217       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1218     }
1219   offset = gfc_evaluate_now (offset, block);
1220   GFC_TYPE_ARRAY_OFFSET (type) = offset;
1221 }
1222
1223
1224 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1225    in SE.  The caller may still use se->expr and se->string_length after
1226    calling this function.  */
1227
1228 void
1229 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1230                            gfc_symbol * sym, gfc_se * se)
1231 {
1232   gfc_interface_sym_mapping *sm;
1233   tree desc;
1234   tree tmp;
1235   tree value;
1236   gfc_symbol *new_sym;
1237   gfc_symtree *root;
1238   gfc_symtree *new_symtree;
1239
1240   /* Create a new symbol to represent the actual argument.  */
1241   new_sym = gfc_new_symbol (sym->name, NULL);
1242   new_sym->ts = sym->ts;
1243   new_sym->attr.referenced = 1;
1244   new_sym->attr.dimension = sym->attr.dimension;
1245   new_sym->attr.pointer = sym->attr.pointer;
1246   new_sym->attr.flavor = sym->attr.flavor;
1247
1248   /* Create a fake symtree for it.  */
1249   root = NULL;
1250   new_symtree = gfc_new_symtree (&root, sym->name);
1251   new_symtree->n.sym = new_sym;
1252   gcc_assert (new_symtree == root);
1253
1254   /* Create a dummy->actual mapping.  */
1255   sm = gfc_getmem (sizeof (*sm));
1256   sm->next = mapping->syms;
1257   sm->old = sym;
1258   sm->new = new_symtree;
1259   mapping->syms = sm;
1260
1261   /* Stabilize the argument's value.  */
1262   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1263
1264   if (sym->ts.type == BT_CHARACTER)
1265     {
1266       /* Create a copy of the dummy argument's length.  */
1267       new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1268
1269       /* If the length is specified as "*", record the length that
1270          the caller is passing.  We should use the callee's length
1271          in all other cases.  */
1272       if (!new_sym->ts.cl->length)
1273         {
1274           se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1275           new_sym->ts.cl->backend_decl = se->string_length;
1276         }
1277     }
1278
1279   /* Use the passed value as-is if the argument is a function.  */
1280   if (sym->attr.flavor == FL_PROCEDURE)
1281     value = se->expr;
1282
1283   /* If the argument is either a string or a pointer to a string,
1284      convert it to a boundless character type.  */
1285   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1286     {
1287       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1288       tmp = build_pointer_type (tmp);
1289       if (sym->attr.pointer)
1290         tmp = build_pointer_type (tmp);
1291
1292       value = fold_convert (tmp, se->expr);
1293       if (sym->attr.pointer)
1294         value = gfc_build_indirect_ref (value);
1295     }
1296
1297   /* If the argument is a scalar or a pointer to an array, dereference it.  */
1298   else if (!sym->attr.dimension || sym->attr.pointer)
1299     value = gfc_build_indirect_ref (se->expr);
1300
1301   /* If the argument is an array descriptor, use it to determine
1302      information about the actual argument's shape.  */
1303   else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1304            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1305     {
1306       /* Get the actual argument's descriptor.  */
1307       desc = gfc_build_indirect_ref (se->expr);
1308
1309       /* Create the replacement variable.  */
1310       tmp = gfc_conv_descriptor_data_get (desc);
1311       value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1312
1313       /* Use DESC to work out the upper bounds, strides and offset.  */
1314       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1315     }
1316   else
1317     /* Otherwise we have a packed array.  */
1318     value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1319
1320   new_sym->backend_decl = value;
1321 }
1322
1323
1324 /* Called once all dummy argument mappings have been added to MAPPING,
1325    but before the mapping is used to evaluate expressions.  Pre-evaluate
1326    the length of each argument, adding any initialization code to PRE and
1327    any finalization code to POST.  */
1328
1329 void
1330 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1331                               stmtblock_t * pre, stmtblock_t * post)
1332 {
1333   gfc_interface_sym_mapping *sym;
1334   gfc_expr *expr;
1335   gfc_se se;
1336
1337   for (sym = mapping->syms; sym; sym = sym->next)
1338     if (sym->new->n.sym->ts.type == BT_CHARACTER
1339         && !sym->new->n.sym->ts.cl->backend_decl)
1340       {
1341         expr = sym->new->n.sym->ts.cl->length;
1342         gfc_apply_interface_mapping_to_expr (mapping, expr);
1343         gfc_init_se (&se, NULL);
1344         gfc_conv_expr (&se, expr);
1345
1346         se.expr = gfc_evaluate_now (se.expr, &se.pre);
1347         gfc_add_block_to_block (pre, &se.pre);
1348         gfc_add_block_to_block (post, &se.post);
1349
1350         sym->new->n.sym->ts.cl->backend_decl = se.expr;
1351       }
1352 }
1353
1354
1355 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1356    constructor C.  */
1357
1358 static void
1359 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1360                                      gfc_constructor * c)
1361 {
1362   for (; c; c = c->next)
1363     {
1364       gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1365       if (c->iterator)
1366         {
1367           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1368           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1369           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1370         }
1371     }
1372 }
1373
1374
1375 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1376    reference REF.  */
1377
1378 static void
1379 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1380                                     gfc_ref * ref)
1381 {
1382   int n;
1383
1384   for (; ref; ref = ref->next)
1385     switch (ref->type)
1386       {
1387       case REF_ARRAY:
1388         for (n = 0; n < ref->u.ar.dimen; n++)
1389           {
1390             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1391             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1392             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1393           }
1394         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1395         break;
1396
1397       case REF_COMPONENT:
1398         break;
1399
1400       case REF_SUBSTRING:
1401         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1402         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1403         break;
1404       }
1405 }
1406
1407
1408 /* EXPR is a copy of an expression that appeared in the interface
1409    associated with MAPPING.  Walk it recursively looking for references to
1410    dummy arguments that MAPPING maps to actual arguments.  Replace each such
1411    reference with a reference to the associated actual argument.  */
1412
1413 static void
1414 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1415                                      gfc_expr * expr)
1416 {
1417   gfc_interface_sym_mapping *sym;
1418   gfc_actual_arglist *actual;
1419
1420   if (!expr)
1421     return;
1422
1423   /* Copying an expression does not copy its length, so do that here.  */
1424   if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1425     {
1426       expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1427       gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1428     }
1429
1430   /* Apply the mapping to any references.  */
1431   gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1432
1433   /* ...and to the expression's symbol, if it has one.  */
1434   if (expr->symtree)
1435     for (sym = mapping->syms; sym; sym = sym->next)
1436       if (sym->old == expr->symtree->n.sym)
1437         expr->symtree = sym->new;
1438
1439   /* ...and to subexpressions in expr->value.  */
1440   switch (expr->expr_type)
1441     {
1442     case EXPR_VARIABLE:
1443     case EXPR_CONSTANT:
1444     case EXPR_NULL:
1445     case EXPR_SUBSTRING:
1446       break;
1447
1448     case EXPR_OP:
1449       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1450       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1451       break;
1452
1453     case EXPR_FUNCTION:
1454       for (sym = mapping->syms; sym; sym = sym->next)
1455         if (sym->old == expr->value.function.esym)
1456           expr->value.function.esym = sym->new->n.sym;
1457
1458       for (actual = expr->value.function.actual; actual; actual = actual->next)
1459         gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1460       break;
1461
1462     case EXPR_ARRAY:
1463     case EXPR_STRUCTURE:
1464       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1465       break;
1466     }
1467 }
1468
1469
1470 /* Evaluate interface expression EXPR using MAPPING.  Store the result
1471    in SE.  */
1472
1473 void
1474 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1475                              gfc_se * se, gfc_expr * expr)
1476 {
1477   expr = gfc_copy_expr (expr);
1478   gfc_apply_interface_mapping_to_expr (mapping, expr);
1479   gfc_conv_expr (se, expr);
1480   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1481   gfc_free_expr (expr);
1482 }
1483
1484
1485 /* Generate code for a procedure call.  Note can return se->post != NULL.
1486    If se->direct_byref is set then se->expr contains the return parameter.
1487    Return nonzero, if the call has alternate specifiers.  */
1488
1489 int
1490 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1491                         gfc_actual_arglist * arg)
1492 {
1493   gfc_interface_mapping mapping;
1494   tree arglist;
1495   tree retargs;
1496   tree tmp;
1497   tree fntype;
1498   gfc_se parmse;
1499   gfc_ss *argss;
1500   gfc_ss_info *info;
1501   int byref;
1502   tree type;
1503   tree var;
1504   tree len;
1505   tree stringargs;
1506   gfc_formal_arglist *formal;
1507   int has_alternate_specifier = 0;
1508   bool need_interface_mapping;
1509   gfc_typespec ts;
1510   gfc_charlen cl;
1511
1512   arglist = NULL_TREE;
1513   retargs = NULL_TREE;
1514   stringargs = NULL_TREE;
1515   var = NULL_TREE;
1516   len = NULL_TREE;
1517
1518   if (se->ss != NULL)
1519     {
1520       if (!sym->attr.elemental)
1521         {
1522           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1523           if (se->ss->useflags)
1524             {
1525               gcc_assert (gfc_return_by_reference (sym)
1526                       && sym->result->attr.dimension);
1527               gcc_assert (se->loop != NULL);
1528
1529               /* Access the previously obtained result.  */
1530               gfc_conv_tmp_array_ref (se);
1531               gfc_advance_se_ss_chain (se);
1532               return 0;
1533             }
1534         }
1535       info = &se->ss->data.info;
1536     }
1537   else
1538     info = NULL;
1539
1540   gfc_init_interface_mapping (&mapping);
1541   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1542                              && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
1543                             || sym->attr.dimension);
1544   formal = sym->formal;
1545   /* Evaluate the arguments.  */
1546   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1547     {
1548       if (arg->expr == NULL)
1549         {
1550
1551           if (se->ignore_optional)
1552             {
1553               /* Some intrinsics have already been resolved to the correct
1554                  parameters.  */
1555               continue;
1556             }
1557           else if (arg->label)
1558             {
1559               has_alternate_specifier = 1;
1560               continue;
1561             }
1562           else
1563             {
1564               /* Pass a NULL pointer for an absent arg.  */
1565               gfc_init_se (&parmse, NULL);
1566               parmse.expr = null_pointer_node;
1567               if (arg->missing_arg_type == BT_CHARACTER)
1568                 parmse.string_length = convert (gfc_charlen_type_node,
1569                                                 integer_zero_node);
1570             }
1571         }
1572       else if (se->ss && se->ss->useflags)
1573         {
1574           /* An elemental function inside a scalarized loop.  */
1575           gfc_init_se (&parmse, se);
1576           gfc_conv_expr_reference (&parmse, arg->expr);
1577         }
1578       else
1579         {
1580           /* A scalar or transformational function.  */
1581           gfc_init_se (&parmse, NULL);
1582           argss = gfc_walk_expr (arg->expr);
1583
1584           if (argss == gfc_ss_terminator)
1585             {
1586               gfc_conv_expr_reference (&parmse, arg->expr);
1587               if (formal && formal->sym->attr.pointer
1588                   && arg->expr->expr_type != EXPR_NULL)
1589                 {
1590                   /* Scalar pointer dummy args require an extra level of
1591                   indirection. The null pointer already contains
1592                   this level of indirection.  */
1593                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1594                 }
1595             }
1596           else
1597             {
1598               /* If the procedure requires an explicit interface, the
1599                  actual argument is passed according to the
1600                  corresponding formal argument.  If the corresponding
1601                  formal argument is a POINTER or assumed shape, we do
1602                  not use g77's calling convention, and pass the
1603                  address of the array descriptor instead. Otherwise we
1604                  use g77's calling convention.  */
1605               int f;
1606               f = (formal != NULL)
1607                   && !formal->sym->attr.pointer
1608                   && formal->sym->as->type != AS_ASSUMED_SHAPE;
1609               f = f || !sym->attr.always_explicit;
1610               gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1611             } 
1612         }
1613
1614       if (formal && need_interface_mapping)
1615         gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1616
1617       gfc_add_block_to_block (&se->pre, &parmse.pre);
1618       gfc_add_block_to_block (&se->post, &parmse.post);
1619
1620       /* Character strings are passed as two parameters, a length and a
1621          pointer.  */
1622       if (parmse.string_length != NULL_TREE)
1623         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1624
1625       arglist = gfc_chainon_list (arglist, parmse.expr);
1626     }
1627   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1628
1629   ts = sym->ts;
1630   if (ts.type == BT_CHARACTER)
1631     {
1632       /* Calculate the length of the returned string.  */
1633       gfc_init_se (&parmse, NULL);
1634       if (need_interface_mapping)
1635         gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1636       else
1637         gfc_conv_expr (&parmse, sym->ts.cl->length);
1638       gfc_add_block_to_block (&se->pre, &parmse.pre);
1639       gfc_add_block_to_block (&se->post, &parmse.post);
1640
1641       /* Set up a charlen structure for it.  */
1642       cl.next = NULL;
1643       cl.length = NULL;
1644       cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1645       ts.cl = &cl;
1646
1647       len = cl.backend_decl;
1648     }
1649
1650   byref = gfc_return_by_reference (sym);
1651   if (byref)
1652     {
1653       if (se->direct_byref)
1654         retargs = gfc_chainon_list (retargs, se->expr);
1655       else if (sym->result->attr.dimension)
1656         {
1657           gcc_assert (se->loop && info);
1658
1659           /* Set the type of the array.  */
1660           tmp = gfc_typenode_for_spec (&ts);
1661           info->dimen = se->loop->dimen;
1662
1663           /* Evaluate the bounds of the result, if known.  */
1664           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1665
1666           /* Allocate a temporary to store the result.  */
1667           gfc_trans_allocate_temp_array (&se->pre, &se->post,
1668                                          se->loop, info, tmp, false);
1669
1670           /* Zero the first stride to indicate a temporary.  */
1671           tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1672           gfc_add_modify_expr (&se->pre, tmp,
1673                                convert (TREE_TYPE (tmp), integer_zero_node));
1674
1675           /* Pass the temporary as the first argument.  */
1676           tmp = info->descriptor;
1677           tmp = gfc_build_addr_expr (NULL, tmp);
1678           retargs = gfc_chainon_list (retargs, tmp);
1679         }
1680       else if (ts.type == BT_CHARACTER)
1681         {
1682           /* Pass the string length.  */
1683           type = gfc_get_character_type (ts.kind, ts.cl);
1684           type = build_pointer_type (type);
1685
1686           /* Return an address to a char[0:len-1]* temporary for
1687              character pointers.  */
1688           if (sym->attr.pointer || sym->attr.allocatable)
1689             {
1690               /* Build char[0:len-1] * pstr.  */
1691               tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1692                                  build_int_cst (gfc_charlen_type_node, 1));
1693               tmp = build_range_type (gfc_array_index_type,
1694                                       gfc_index_zero_node, tmp);
1695               tmp = build_array_type (gfc_character1_type_node, tmp);
1696               var = gfc_create_var (build_pointer_type (tmp), "pstr");
1697
1698               /* Provide an address expression for the function arguments.  */
1699               var = gfc_build_addr_expr (NULL, var);
1700             }
1701           else
1702             var = gfc_conv_string_tmp (se, type, len);
1703
1704           retargs = gfc_chainon_list (retargs, var);
1705         }
1706       else
1707         {
1708           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1709
1710           type = gfc_get_complex_type (ts.kind);
1711           var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1712           retargs = gfc_chainon_list (retargs, var);
1713         }
1714
1715       /* Add the string length to the argument list.  */
1716       if (ts.type == BT_CHARACTER)
1717         retargs = gfc_chainon_list (retargs, len);
1718     }
1719   gfc_free_interface_mapping (&mapping);
1720
1721   /* Add the return arguments.  */
1722   arglist = chainon (retargs, arglist);
1723
1724   /* Add the hidden string length parameters to the arguments.  */
1725   arglist = chainon (arglist, stringargs);
1726
1727   /* Generate the actual call.  */
1728   gfc_conv_function_val (se, sym);
1729   /* If there are alternate return labels, function type should be
1730      integer.  Can't modify the type in place though, since it can be shared
1731      with other functions.  */
1732   if (has_alternate_specifier
1733       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1734     {
1735       gcc_assert (! sym->attr.dummy);
1736       TREE_TYPE (sym->backend_decl)
1737         = build_function_type (integer_type_node,
1738                                TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1739       se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1740     }
1741
1742   fntype = TREE_TYPE (TREE_TYPE (se->expr));
1743   se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1744                      arglist, NULL_TREE);
1745
1746   /* If we have a pointer function, but we don't want a pointer, e.g.
1747      something like
1748         x = f()
1749      where f is pointer valued, we have to dereference the result.  */
1750   if (!se->want_pointer && !byref && sym->attr.pointer)
1751     se->expr = gfc_build_indirect_ref (se->expr);
1752
1753   /* f2c calling conventions require a scalar default real function to
1754      return a double precision result.  Convert this back to default
1755      real.  We only care about the cases that can happen in Fortran 77.
1756   */
1757   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1758       && sym->ts.kind == gfc_default_real_kind
1759       && !sym->attr.always_explicit)
1760     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1761
1762   /* A pure function may still have side-effects - it may modify its
1763      parameters.  */
1764   TREE_SIDE_EFFECTS (se->expr) = 1;
1765 #if 0
1766   if (!sym->attr.pure)
1767     TREE_SIDE_EFFECTS (se->expr) = 1;
1768 #endif
1769
1770   if (byref)
1771     {
1772       /* Add the function call to the pre chain.  There is no expression.  */
1773       gfc_add_expr_to_block (&se->pre, se->expr);
1774       se->expr = NULL_TREE;
1775
1776       if (!se->direct_byref)
1777         {
1778           if (sym->attr.dimension)
1779             {
1780               if (flag_bounds_check)
1781                 {
1782                   /* Check the data pointer hasn't been modified.  This would
1783                      happen in a function returning a pointer.  */
1784                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
1785                   tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1786                   gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1787                 }
1788               se->expr = info->descriptor;
1789               /* Bundle in the string length.  */
1790               se->string_length = len;
1791             }
1792           else if (sym->ts.type == BT_CHARACTER)
1793             {
1794               /* Dereference for character pointer results.  */
1795               if (sym->attr.pointer || sym->attr.allocatable)
1796                 se->expr = gfc_build_indirect_ref (var);
1797               else
1798                 se->expr = var;
1799
1800               se->string_length = len;
1801             }
1802           else
1803             {
1804               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1805               se->expr = gfc_build_indirect_ref (var);
1806             }
1807         }
1808     }
1809
1810   return has_alternate_specifier;
1811 }
1812
1813
1814 /* Generate code to copy a string.  */
1815
1816 static void
1817 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1818                        tree slen, tree src)
1819 {
1820   tree tmp;
1821
1822   tmp = NULL_TREE;
1823   tmp = gfc_chainon_list (tmp, dlen);
1824   tmp = gfc_chainon_list (tmp, dest);
1825   tmp = gfc_chainon_list (tmp, slen);
1826   tmp = gfc_chainon_list (tmp, src);
1827   tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1828   gfc_add_expr_to_block (block, tmp);
1829 }
1830
1831
1832 /* Translate a statement function.
1833    The value of a statement function reference is obtained by evaluating the
1834    expression using the values of the actual arguments for the values of the
1835    corresponding dummy arguments.  */
1836
1837 static void
1838 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1839 {
1840   gfc_symbol *sym;
1841   gfc_symbol *fsym;
1842   gfc_formal_arglist *fargs;
1843   gfc_actual_arglist *args;
1844   gfc_se lse;
1845   gfc_se rse;
1846   gfc_saved_var *saved_vars;
1847   tree *temp_vars;
1848   tree type;
1849   tree tmp;
1850   int n;
1851
1852   sym = expr->symtree->n.sym;
1853   args = expr->value.function.actual;
1854   gfc_init_se (&lse, NULL);
1855   gfc_init_se (&rse, NULL);
1856
1857   n = 0;
1858   for (fargs = sym->formal; fargs; fargs = fargs->next)
1859     n++;
1860   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1861   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1862
1863   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1864     {
1865       /* Each dummy shall be specified, explicitly or implicitly, to be
1866          scalar.  */
1867       gcc_assert (fargs->sym->attr.dimension == 0);
1868       fsym = fargs->sym;
1869
1870       /* Create a temporary to hold the value.  */
1871       type = gfc_typenode_for_spec (&fsym->ts);
1872       temp_vars[n] = gfc_create_var (type, fsym->name);
1873
1874       if (fsym->ts.type == BT_CHARACTER)
1875         {
1876           /* Copy string arguments.  */
1877           tree arglen;
1878
1879           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1880                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1881
1882           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1883           tmp = gfc_build_addr_expr (build_pointer_type (type),
1884                                      temp_vars[n]);
1885
1886           gfc_conv_expr (&rse, args->expr);
1887           gfc_conv_string_parameter (&rse);
1888           gfc_add_block_to_block (&se->pre, &lse.pre);
1889           gfc_add_block_to_block (&se->pre, &rse.pre);
1890
1891           gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1892                                  rse.expr);
1893           gfc_add_block_to_block (&se->pre, &lse.post);
1894           gfc_add_block_to_block (&se->pre, &rse.post);
1895         }
1896       else
1897         {
1898           /* For everything else, just evaluate the expression.  */
1899           gfc_conv_expr (&lse, args->expr);
1900
1901           gfc_add_block_to_block (&se->pre, &lse.pre);
1902           gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1903           gfc_add_block_to_block (&se->pre, &lse.post);
1904         }
1905
1906       args = args->next;
1907     }
1908
1909   /* Use the temporary variables in place of the real ones.  */
1910   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1911     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1912
1913   gfc_conv_expr (se, sym->value);
1914
1915   if (sym->ts.type == BT_CHARACTER)
1916     {
1917       gfc_conv_const_charlen (sym->ts.cl);
1918
1919       /* Force the expression to the correct length.  */
1920       if (!INTEGER_CST_P (se->string_length)
1921           || tree_int_cst_lt (se->string_length,
1922                               sym->ts.cl->backend_decl))
1923         {
1924           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1925           tmp = gfc_create_var (type, sym->name);
1926           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1927           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1928                                  se->string_length, se->expr);
1929           se->expr = tmp;
1930         }
1931       se->string_length = sym->ts.cl->backend_decl;
1932     }
1933
1934   /* Restore the original variables.  */
1935   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1936     gfc_restore_sym (fargs->sym, &saved_vars[n]);
1937   gfc_free (saved_vars);
1938 }
1939
1940
1941 /* Translate a function expression.  */
1942
1943 static void
1944 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1945 {
1946   gfc_symbol *sym;
1947
1948   if (expr->value.function.isym)
1949     {
1950       gfc_conv_intrinsic_function (se, expr);
1951       return;
1952     }
1953
1954   /* We distinguish statement functions from general functions to improve
1955      runtime performance.  */
1956   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1957     {
1958       gfc_conv_statement_function (se, expr);
1959       return;
1960     }
1961
1962   /* expr.value.function.esym is the resolved (specific) function symbol for
1963      most functions.  However this isn't set for dummy procedures.  */
1964   sym = expr->value.function.esym;
1965   if (!sym)
1966     sym = expr->symtree->n.sym;
1967   gfc_conv_function_call (se, sym, expr->value.function.actual);
1968 }
1969
1970
1971 static void
1972 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1973 {
1974   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1975   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1976
1977   gfc_conv_tmp_array_ref (se);
1978   gfc_advance_se_ss_chain (se);
1979 }
1980
1981
1982 /* Build a static initializer.  EXPR is the expression for the initial value.
1983    The other parameters describe the variable of the component being 
1984    initialized. EXPR may be null.  */
1985
1986 tree
1987 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1988                       bool array, bool pointer)
1989 {
1990   gfc_se se;
1991
1992   if (!(expr || pointer))
1993     return NULL_TREE;
1994
1995   if (array)
1996     {
1997       /* Arrays need special handling.  */
1998       if (pointer)
1999         return gfc_build_null_descriptor (type);
2000       else
2001         return gfc_conv_array_initializer (type, expr);
2002     }
2003   else if (pointer)
2004     return fold_convert (type, null_pointer_node);
2005   else
2006     {
2007       switch (ts->type)
2008         {
2009         case BT_DERIVED:
2010           gfc_init_se (&se, NULL);
2011           gfc_conv_structure (&se, expr, 1);
2012           return se.expr;
2013
2014         case BT_CHARACTER:
2015           return gfc_conv_string_init (ts->cl->backend_decl,expr);
2016
2017         default:
2018           gfc_init_se (&se, NULL);
2019           gfc_conv_constant (&se, expr);
2020           return se.expr;
2021         }
2022     }
2023 }
2024   
2025 static tree
2026 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2027 {
2028   gfc_se rse;
2029   gfc_se lse;
2030   gfc_ss *rss;
2031   gfc_ss *lss;
2032   stmtblock_t body;
2033   stmtblock_t block;
2034   gfc_loopinfo loop;
2035   int n;
2036   tree tmp;
2037
2038   gfc_start_block (&block);
2039
2040   /* Initialize the scalarizer.  */
2041   gfc_init_loopinfo (&loop);
2042
2043   gfc_init_se (&lse, NULL);
2044   gfc_init_se (&rse, NULL);
2045
2046   /* Walk the rhs.  */
2047   rss = gfc_walk_expr (expr);
2048   if (rss == gfc_ss_terminator)
2049     {
2050       /* The rhs is scalar.  Add a ss for the expression.  */
2051       rss = gfc_get_ss ();
2052       rss->next = gfc_ss_terminator;
2053       rss->type = GFC_SS_SCALAR;
2054       rss->expr = expr;
2055     }
2056
2057   /* Create a SS for the destination.  */
2058   lss = gfc_get_ss ();
2059   lss->type = GFC_SS_COMPONENT;
2060   lss->expr = NULL;
2061   lss->shape = gfc_get_shape (cm->as->rank);
2062   lss->next = gfc_ss_terminator;
2063   lss->data.info.dimen = cm->as->rank;
2064   lss->data.info.descriptor = dest;
2065   lss->data.info.data = gfc_conv_array_data (dest);
2066   lss->data.info.offset = gfc_conv_array_offset (dest);
2067   for (n = 0; n < cm->as->rank; n++)
2068     {
2069       lss->data.info.dim[n] = n;
2070       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2071       lss->data.info.stride[n] = gfc_index_one_node;
2072
2073       mpz_init (lss->shape[n]);
2074       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2075                cm->as->lower[n]->value.integer);
2076       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2077     }
2078   
2079   /* Associate the SS with the loop.  */
2080   gfc_add_ss_to_loop (&loop, lss);
2081   gfc_add_ss_to_loop (&loop, rss);
2082
2083   /* Calculate the bounds of the scalarization.  */
2084   gfc_conv_ss_startstride (&loop);
2085
2086   /* Setup the scalarizing loops.  */
2087   gfc_conv_loop_setup (&loop);
2088
2089   /* Setup the gfc_se structures.  */
2090   gfc_copy_loopinfo_to_se (&lse, &loop);
2091   gfc_copy_loopinfo_to_se (&rse, &loop);
2092
2093   rse.ss = rss;
2094   gfc_mark_ss_chain_used (rss, 1);
2095   lse.ss = lss;
2096   gfc_mark_ss_chain_used (lss, 1);
2097
2098   /* Start the scalarized loop body.  */
2099   gfc_start_scalarized_body (&loop, &body);
2100
2101   gfc_conv_tmp_array_ref (&lse);
2102   if (cm->ts.type == BT_CHARACTER)
2103     lse.string_length = cm->ts.cl->backend_decl;
2104
2105   gfc_conv_expr (&rse, expr);
2106
2107   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2108   gfc_add_expr_to_block (&body, tmp);
2109
2110   gcc_assert (rse.ss == gfc_ss_terminator);
2111
2112   /* Generate the copying loops.  */
2113   gfc_trans_scalarizing_loops (&loop, &body);
2114
2115   /* Wrap the whole thing up.  */
2116   gfc_add_block_to_block (&block, &loop.pre);
2117   gfc_add_block_to_block (&block, &loop.post);
2118
2119   for (n = 0; n < cm->as->rank; n++)
2120     mpz_clear (lss->shape[n]);
2121   gfc_free (lss->shape);
2122
2123   gfc_cleanup_loop (&loop);
2124
2125   return gfc_finish_block (&block);
2126 }
2127
2128 /* Assign a single component of a derived type constructor.  */
2129
2130 static tree
2131 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2132 {
2133   gfc_se se;
2134   gfc_ss *rss;
2135   stmtblock_t block;
2136   tree tmp;
2137
2138   gfc_start_block (&block);
2139   if (cm->pointer)
2140     {
2141       gfc_init_se (&se, NULL);
2142       /* Pointer component.  */
2143       if (cm->dimension)
2144         {
2145           /* Array pointer.  */
2146           if (expr->expr_type == EXPR_NULL)
2147             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2148           else
2149             {
2150               rss = gfc_walk_expr (expr);
2151               se.direct_byref = 1;
2152               se.expr = dest;
2153               gfc_conv_expr_descriptor (&se, expr, rss);
2154               gfc_add_block_to_block (&block, &se.pre);
2155               gfc_add_block_to_block (&block, &se.post);
2156             }
2157         }
2158       else
2159         {
2160           /* Scalar pointers.  */
2161           se.want_pointer = 1;
2162           gfc_conv_expr (&se, expr);
2163           gfc_add_block_to_block (&block, &se.pre);
2164           gfc_add_modify_expr (&block, dest,
2165                                fold_convert (TREE_TYPE (dest), se.expr));
2166           gfc_add_block_to_block (&block, &se.post);
2167         }
2168     }
2169   else if (cm->dimension)
2170     {
2171       tmp = gfc_trans_subarray_assign (dest, cm, expr);
2172       gfc_add_expr_to_block (&block, tmp);
2173     }
2174   else if (expr->ts.type == BT_DERIVED)
2175     {
2176       /* Nested derived type.  */
2177       tmp = gfc_trans_structure_assign (dest, expr);
2178       gfc_add_expr_to_block (&block, tmp);
2179     }
2180   else
2181     {
2182       /* Scalar component.  */
2183       gfc_se lse;
2184
2185       gfc_init_se (&se, NULL);
2186       gfc_init_se (&lse, NULL);
2187
2188       gfc_conv_expr (&se, expr);
2189       if (cm->ts.type == BT_CHARACTER)
2190         lse.string_length = cm->ts.cl->backend_decl;
2191       lse.expr = dest;
2192       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2193       gfc_add_expr_to_block (&block, tmp);
2194     }
2195   return gfc_finish_block (&block);
2196 }
2197
2198 /* Assign a derived type constructor to a variable.  */
2199
2200 static tree
2201 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2202 {
2203   gfc_constructor *c;
2204   gfc_component *cm;
2205   stmtblock_t block;
2206   tree field;
2207   tree tmp;
2208
2209   gfc_start_block (&block);
2210   cm = expr->ts.derived->components;
2211   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2212     {
2213       /* Skip absent members in default initializers.  */
2214       if (!c->expr)
2215         continue;
2216
2217       field = cm->backend_decl;
2218       tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2219       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2220       gfc_add_expr_to_block (&block, tmp);
2221     }
2222   return gfc_finish_block (&block);
2223 }
2224
2225 /* Build an expression for a constructor. If init is nonzero then
2226    this is part of a static variable initializer.  */
2227
2228 void
2229 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2230 {
2231   gfc_constructor *c;
2232   gfc_component *cm;
2233   tree val;
2234   tree type;
2235   tree tmp;
2236   VEC(constructor_elt,gc) *v = NULL;
2237
2238   gcc_assert (se->ss == NULL);
2239   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2240   type = gfc_typenode_for_spec (&expr->ts);
2241
2242   if (!init)
2243     {
2244       /* Create a temporary variable and fill it in.  */
2245       se->expr = gfc_create_var (type, expr->ts.derived->name);
2246       tmp = gfc_trans_structure_assign (se->expr, expr);
2247       gfc_add_expr_to_block (&se->pre, tmp);
2248       return;
2249     }
2250
2251   cm = expr->ts.derived->components;
2252   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2253     {
2254       /* Skip absent members in default initializers.  */
2255       if (!c->expr)
2256         continue;
2257
2258       val = gfc_conv_initializer (c->expr, &cm->ts,
2259           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2260
2261       /* Append it to the constructor list.  */
2262       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2263     }
2264   se->expr = build_constructor (type, v);
2265 }
2266
2267
2268 /* Translate a substring expression.  */
2269
2270 static void
2271 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2272 {
2273   gfc_ref *ref;
2274
2275   ref = expr->ref;
2276
2277   gcc_assert (ref->type == REF_SUBSTRING);
2278
2279   se->expr = gfc_build_string_const(expr->value.character.length,
2280                                     expr->value.character.string);
2281   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2282   TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2283
2284   gfc_conv_substring(se,ref,expr->ts.kind);
2285 }
2286
2287
2288 /* Entry point for expression translation.  Evaluates a scalar quantity.
2289    EXPR is the expression to be translated, and SE is the state structure if
2290    called from within the scalarized.  */
2291
2292 void
2293 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2294 {
2295   if (se->ss && se->ss->expr == expr
2296       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2297     {
2298       /* Substitute a scalar expression evaluated outside the scalarization
2299          loop.  */
2300       se->expr = se->ss->data.scalar.expr;
2301       se->string_length = se->ss->string_length;
2302       gfc_advance_se_ss_chain (se);
2303       return;
2304     }
2305
2306   switch (expr->expr_type)
2307     {
2308     case EXPR_OP:
2309       gfc_conv_expr_op (se, expr);
2310       break;
2311
2312     case EXPR_FUNCTION:
2313       gfc_conv_function_expr (se, expr);
2314       break;
2315
2316     case EXPR_CONSTANT:
2317       gfc_conv_constant (se, expr);
2318       break;
2319
2320     case EXPR_VARIABLE:
2321       gfc_conv_variable (se, expr);
2322       break;
2323
2324     case EXPR_NULL:
2325       se->expr = null_pointer_node;
2326       break;
2327
2328     case EXPR_SUBSTRING:
2329       gfc_conv_substring_expr (se, expr);
2330       break;
2331
2332     case EXPR_STRUCTURE:
2333       gfc_conv_structure (se, expr, 0);
2334       break;
2335
2336     case EXPR_ARRAY:
2337       gfc_conv_array_constructor_expr (se, expr);
2338       break;
2339
2340     default:
2341       gcc_unreachable ();
2342       break;
2343     }
2344 }
2345
2346 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2347    of an assignment.  */
2348 void
2349 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2350 {
2351   gfc_conv_expr (se, expr);
2352   /* All numeric lvalues should have empty post chains.  If not we need to
2353      figure out a way of rewriting an lvalue so that it has no post chain.  */
2354   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2355 }
2356
2357 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2358    numeric expressions.  Used for scalar values whee inserting cleanup code
2359    is inconvenient.  */
2360 void
2361 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2362 {
2363   tree val;
2364
2365   gcc_assert (expr->ts.type != BT_CHARACTER);
2366   gfc_conv_expr (se, expr);
2367   if (se->post.head)
2368     {
2369       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2370       gfc_add_modify_expr (&se->pre, val, se->expr);
2371       se->expr = val;
2372       gfc_add_block_to_block (&se->pre, &se->post);
2373     }
2374 }
2375
2376 /* Helper to translate and expression and convert it to a particular type.  */
2377 void
2378 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2379 {
2380   gfc_conv_expr_val (se, expr);
2381   se->expr = convert (type, se->expr);
2382 }
2383
2384
2385 /* Converts an expression so that it can be passed by reference.  Scalar
2386    values only.  */
2387
2388 void
2389 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2390 {
2391   tree var;
2392
2393   if (se->ss && se->ss->expr == expr
2394       && se->ss->type == GFC_SS_REFERENCE)
2395     {
2396       se->expr = se->ss->data.scalar.expr;
2397       se->string_length = se->ss->string_length;
2398       gfc_advance_se_ss_chain (se);
2399       return;
2400     }
2401
2402   if (expr->ts.type == BT_CHARACTER)
2403     {
2404       gfc_conv_expr (se, expr);
2405       gfc_conv_string_parameter (se);
2406       return;
2407     }
2408
2409   if (expr->expr_type == EXPR_VARIABLE)
2410     {
2411       se->want_pointer = 1;
2412       gfc_conv_expr (se, expr);
2413       if (se->post.head)
2414         {
2415           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2416           gfc_add_modify_expr (&se->pre, var, se->expr);
2417           gfc_add_block_to_block (&se->pre, &se->post);
2418           se->expr = var;
2419         }
2420       return;
2421     }
2422
2423   gfc_conv_expr (se, expr);
2424
2425   /* Create a temporary var to hold the value.  */
2426   if (TREE_CONSTANT (se->expr))
2427     {
2428       var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2429       DECL_INITIAL (var) = se->expr;
2430       pushdecl (var);
2431     }
2432   else
2433     {
2434       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2435       gfc_add_modify_expr (&se->pre, var, se->expr);
2436     }
2437   gfc_add_block_to_block (&se->pre, &se->post);
2438
2439   /* Take the address of that value.  */
2440   se->expr = gfc_build_addr_expr (NULL, var);
2441 }
2442
2443
2444 tree
2445 gfc_trans_pointer_assign (gfc_code * code)
2446 {
2447   return gfc_trans_pointer_assignment (code->expr, code->expr2);
2448 }
2449
2450
2451 /* Generate code for a pointer assignment.  */
2452
2453 tree
2454 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2455 {
2456   gfc_se lse;
2457   gfc_se rse;
2458   gfc_ss *lss;
2459   gfc_ss *rss;
2460   stmtblock_t block;
2461   tree desc;
2462   tree tmp;
2463
2464   gfc_start_block (&block);
2465
2466   gfc_init_se (&lse, NULL);
2467
2468   lss = gfc_walk_expr (expr1);
2469   rss = gfc_walk_expr (expr2);
2470   if (lss == gfc_ss_terminator)
2471     {
2472       /* Scalar pointers.  */
2473       lse.want_pointer = 1;
2474       gfc_conv_expr (&lse, expr1);
2475       gcc_assert (rss == gfc_ss_terminator);
2476       gfc_init_se (&rse, NULL);
2477       rse.want_pointer = 1;
2478       gfc_conv_expr (&rse, expr2);
2479       gfc_add_block_to_block (&block, &lse.pre);
2480       gfc_add_block_to_block (&block, &rse.pre);
2481       gfc_add_modify_expr (&block, lse.expr,
2482                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
2483       gfc_add_block_to_block (&block, &rse.post);
2484       gfc_add_block_to_block (&block, &lse.post);
2485     }
2486   else
2487     {
2488       /* Array pointer.  */
2489       gfc_conv_expr_descriptor (&lse, expr1, lss);
2490       switch (expr2->expr_type)
2491         {
2492         case EXPR_NULL:
2493           /* Just set the data pointer to null.  */
2494           gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2495           break;
2496
2497         case EXPR_VARIABLE:
2498           /* Assign directly to the pointer's descriptor.  */
2499           lse.direct_byref = 1;
2500           gfc_conv_expr_descriptor (&lse, expr2, rss);
2501           break;
2502
2503         default:
2504           /* Assign to a temporary descriptor and then copy that
2505              temporary to the pointer.  */
2506           desc = lse.expr;
2507           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2508
2509           lse.expr = tmp;
2510           lse.direct_byref = 1;
2511           gfc_conv_expr_descriptor (&lse, expr2, rss);
2512           gfc_add_modify_expr (&lse.pre, desc, tmp);
2513           break;
2514         }
2515       gfc_add_block_to_block (&block, &lse.pre);
2516       gfc_add_block_to_block (&block, &lse.post);
2517     }
2518   return gfc_finish_block (&block);
2519 }
2520
2521
2522 /* Makes sure se is suitable for passing as a function string parameter.  */
2523 /* TODO: Need to check all callers fo this function.  It may be abused.  */
2524
2525 void
2526 gfc_conv_string_parameter (gfc_se * se)
2527 {
2528   tree type;
2529
2530   if (TREE_CODE (se->expr) == STRING_CST)
2531     {
2532       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2533       return;
2534     }
2535
2536   type = TREE_TYPE (se->expr);
2537   if (TYPE_STRING_FLAG (type))
2538     {
2539       gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2540       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2541     }
2542
2543   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2544   gcc_assert (se->string_length
2545           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2546 }
2547
2548
2549 /* Generate code for assignment of scalar variables.  Includes character
2550    strings.  */
2551
2552 tree
2553 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2554 {
2555   stmtblock_t block;
2556
2557   gfc_init_block (&block);
2558
2559   if (type == BT_CHARACTER)
2560     {
2561       gcc_assert (lse->string_length != NULL_TREE
2562               && rse->string_length != NULL_TREE);
2563
2564       gfc_conv_string_parameter (lse);
2565       gfc_conv_string_parameter (rse);
2566
2567       gfc_add_block_to_block (&block, &lse->pre);
2568       gfc_add_block_to_block (&block, &rse->pre);
2569
2570       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2571                              rse->string_length, rse->expr);
2572     }
2573   else
2574     {
2575       gfc_add_block_to_block (&block, &lse->pre);
2576       gfc_add_block_to_block (&block, &rse->pre);
2577
2578       gfc_add_modify_expr (&block, lse->expr,
2579                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
2580     }
2581
2582   gfc_add_block_to_block (&block, &lse->post);
2583   gfc_add_block_to_block (&block, &rse->post);
2584
2585   return gfc_finish_block (&block);
2586 }
2587
2588
2589 /* Try to translate array(:) = func (...), where func is a transformational
2590    array function, without using a temporary.  Returns NULL is this isn't the
2591    case.  */
2592
2593 static tree
2594 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2595 {
2596   gfc_se se;
2597   gfc_ss *ss;
2598   gfc_ref * ref;
2599   bool seen_array_ref;
2600
2601   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
2602   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2603     return NULL;
2604
2605   /* Elemental functions don't need a temporary anyway.  */
2606   if (expr2->value.function.esym != NULL
2607       && expr2->value.function.esym->attr.elemental)
2608     return NULL;
2609
2610   /* Fail if EXPR1 can't be expressed as a descriptor.  */
2611   if (gfc_ref_needs_temporary_p (expr1->ref))
2612     return NULL;
2613
2614   /* Check that no LHS component references appear during an array
2615      reference. This is needed because we do not have the means to
2616      span any arbitrary stride with an array descriptor. This check
2617      is not needed for the rhs because the function result has to be
2618      a complete type.  */
2619   seen_array_ref = false;
2620   for (ref = expr1->ref; ref; ref = ref->next)
2621     {
2622       if (ref->type == REF_ARRAY)
2623         seen_array_ref= true;
2624       else if (ref->type == REF_COMPONENT && seen_array_ref)
2625         return NULL;
2626     }
2627
2628   /* Check for a dependency.  */
2629   if (gfc_check_fncall_dependency (expr1, expr2))
2630     return NULL;
2631
2632   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2633      functions.  */
2634   gcc_assert (expr2->value.function.isym
2635               || (gfc_return_by_reference (expr2->value.function.esym)
2636               && expr2->value.function.esym->result->attr.dimension));
2637
2638   ss = gfc_walk_expr (expr1);
2639   gcc_assert (ss != gfc_ss_terminator);
2640   gfc_init_se (&se, NULL);
2641   gfc_start_block (&se.pre);
2642   se.want_pointer = 1;
2643
2644   gfc_conv_array_parameter (&se, expr1, ss, 0);
2645
2646   se.direct_byref = 1;
2647   se.ss = gfc_walk_expr (expr2);
2648   gcc_assert (se.ss != gfc_ss_terminator);
2649   gfc_conv_function_expr (&se, expr2);
2650   gfc_add_block_to_block (&se.pre, &se.post);
2651
2652   return gfc_finish_block (&se.pre);
2653 }
2654
2655
2656 /* Translate an assignment.  Most of the code is concerned with
2657    setting up the scalarizer.  */
2658
2659 tree
2660 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2661 {
2662   gfc_se lse;
2663   gfc_se rse;
2664   gfc_ss *lss;
2665   gfc_ss *lss_section;
2666   gfc_ss *rss;
2667   gfc_loopinfo loop;
2668   tree tmp;
2669   stmtblock_t block;
2670   stmtblock_t body;
2671
2672   /* Special case a single function returning an array.  */
2673   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2674     {
2675       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2676       if (tmp)
2677         return tmp;
2678     }
2679
2680   /* Assignment of the form lhs = rhs.  */
2681   gfc_start_block (&block);
2682
2683   gfc_init_se (&lse, NULL);
2684   gfc_init_se (&rse, NULL);
2685
2686   /* Walk the lhs.  */
2687   lss = gfc_walk_expr (expr1);
2688   rss = NULL;
2689   if (lss != gfc_ss_terminator)
2690     {
2691       /* The assignment needs scalarization.  */
2692       lss_section = lss;
2693
2694       /* Find a non-scalar SS from the lhs.  */
2695       while (lss_section != gfc_ss_terminator
2696              && lss_section->type != GFC_SS_SECTION)
2697         lss_section = lss_section->next;
2698
2699       gcc_assert (lss_section != gfc_ss_terminator);
2700
2701       /* Initialize the scalarizer.  */
2702       gfc_init_loopinfo (&loop);
2703
2704       /* Walk the rhs.  */
2705       rss = gfc_walk_expr (expr2);
2706       if (rss == gfc_ss_terminator)
2707         {
2708           /* The rhs is scalar.  Add a ss for the expression.  */
2709           rss = gfc_get_ss ();
2710           rss->next = gfc_ss_terminator;
2711           rss->type = GFC_SS_SCALAR;
2712           rss->expr = expr2;
2713         }
2714       /* Associate the SS with the loop.  */
2715       gfc_add_ss_to_loop (&loop, lss);
2716       gfc_add_ss_to_loop (&loop, rss);
2717
2718       /* Calculate the bounds of the scalarization.  */
2719       gfc_conv_ss_startstride (&loop);
2720       /* Resolve any data dependencies in the statement.  */
2721       gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2722       /* Setup the scalarizing loops.  */
2723       gfc_conv_loop_setup (&loop);
2724
2725       /* Setup the gfc_se structures.  */
2726       gfc_copy_loopinfo_to_se (&lse, &loop);
2727       gfc_copy_loopinfo_to_se (&rse, &loop);
2728
2729       rse.ss = rss;
2730       gfc_mark_ss_chain_used (rss, 1);
2731       if (loop.temp_ss == NULL)
2732         {
2733           lse.ss = lss;
2734           gfc_mark_ss_chain_used (lss, 1);
2735         }
2736       else
2737         {
2738           lse.ss = loop.temp_ss;
2739           gfc_mark_ss_chain_used (lss, 3);
2740           gfc_mark_ss_chain_used (loop.temp_ss, 3);
2741         }
2742
2743       /* Start the scalarized loop body.  */
2744       gfc_start_scalarized_body (&loop, &body);
2745     }
2746   else
2747     gfc_init_block (&body);
2748
2749   /* Translate the expression.  */
2750   gfc_conv_expr (&rse, expr2);
2751
2752   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2753     {
2754       gfc_conv_tmp_array_ref (&lse);
2755       gfc_advance_se_ss_chain (&lse);
2756     }
2757   else
2758     gfc_conv_expr (&lse, expr1);
2759
2760   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2761   gfc_add_expr_to_block (&body, tmp);
2762
2763   if (lss == gfc_ss_terminator)
2764     {
2765       /* Use the scalar assignment as is.  */
2766       gfc_add_block_to_block (&block, &body);
2767     }
2768   else
2769     {
2770       gcc_assert (lse.ss == gfc_ss_terminator
2771                   && rse.ss == gfc_ss_terminator);
2772
2773       if (loop.temp_ss != NULL)
2774         {
2775           gfc_trans_scalarized_loop_boundary (&loop, &body);
2776
2777           /* We need to copy the temporary to the actual lhs.  */
2778           gfc_init_se (&lse, NULL);
2779           gfc_init_se (&rse, NULL);
2780           gfc_copy_loopinfo_to_se (&lse, &loop);
2781           gfc_copy_loopinfo_to_se (&rse, &loop);
2782
2783           rse.ss = loop.temp_ss;
2784           lse.ss = lss;
2785
2786           gfc_conv_tmp_array_ref (&rse);
2787           gfc_advance_se_ss_chain (&rse);
2788           gfc_conv_expr (&lse, expr1);
2789
2790           gcc_assert (lse.ss == gfc_ss_terminator
2791                       && rse.ss == gfc_ss_terminator);
2792
2793           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2794           gfc_add_expr_to_block (&body, tmp);
2795         }
2796       /* Generate the copying loops.  */
2797       gfc_trans_scalarizing_loops (&loop, &body);
2798
2799       /* Wrap the whole thing up.  */
2800       gfc_add_block_to_block (&block, &loop.pre);
2801       gfc_add_block_to_block (&block, &loop.post);
2802
2803       gfc_cleanup_loop (&loop);
2804     }
2805
2806   return gfc_finish_block (&block);
2807 }
2808
2809 tree
2810 gfc_trans_assign (gfc_code * code)
2811 {
2812   return gfc_trans_assignment (code->expr, code->expr2);
2813 }