OSDN Git Service

caf3d754a2382267c63ab7ba29ce8bfe7d7b2df2
[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, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, 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
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44
45 /* Copy the scalarization loop variables.  */
46
47 static void
48 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
49 {
50   dest->ss = src->ss;
51   dest->loop = src->loop;
52 }
53
54
55 /* Initialize a simple expression holder.
56
57    Care must be taken when multiple se are created with the same parent.
58    The child se must be kept in sync.  The easiest way is to delay creation
59    of a child se until after after the previous se has been translated.  */
60
61 void
62 gfc_init_se (gfc_se * se, gfc_se * parent)
63 {
64   memset (se, 0, sizeof (gfc_se));
65   gfc_init_block (&se->pre);
66   gfc_init_block (&se->post);
67
68   se->parent = parent;
69
70   if (parent)
71     gfc_copy_se_loopvars (se, parent);
72 }
73
74
75 /* Advances to the next SS in the chain.  Use this rather than setting
76    se->ss = se->ss->next because all the parents needs to be kept in sync.
77    See gfc_init_se.  */
78
79 void
80 gfc_advance_se_ss_chain (gfc_se * se)
81 {
82   gfc_se *p;
83
84   gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
85
86   p = se;
87   /* Walk down the parent chain.  */
88   while (p != NULL)
89     {
90       /* Simple consistency check.  */
91       gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
92
93       p->ss = p->ss->next;
94
95       p = p->parent;
96     }
97 }
98
99
100 /* Ensures the result of the expression as either a temporary variable
101    or a constant so that it can be used repeatedly.  */
102
103 void
104 gfc_make_safe_expr (gfc_se * se)
105 {
106   tree var;
107
108   if (CONSTANT_CLASS_P (se->expr))
109     return;
110
111   /* We need a temporary for this result.  */
112   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
113   gfc_add_modify_expr (&se->pre, var, se->expr);
114   se->expr = var;
115 }
116
117
118 /* Return an expression which determines if a dummy parameter is present.
119    Also used for arguments to procedures with multiple entry points.  */
120
121 tree
122 gfc_conv_expr_present (gfc_symbol * sym)
123 {
124   tree decl;
125
126   gcc_assert (sym->attr.dummy);
127
128   decl = gfc_get_symbol_decl (sym);
129   if (TREE_CODE (decl) != PARM_DECL)
130     {
131       /* Array parameters use a temporary descriptor, we want the real
132          parameter.  */
133       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
134              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
135       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
136     }
137   return build2 (NE_EXPR, boolean_type_node, decl,
138                  fold_convert (TREE_TYPE (decl), null_pointer_node));
139 }
140
141
142 /* Get the character length of an expression, looking through gfc_refs
143    if necessary.  */
144
145 tree
146 gfc_get_expr_charlen (gfc_expr *e)
147 {
148   gfc_ref *r;
149   tree length;
150
151   gcc_assert (e->expr_type == EXPR_VARIABLE 
152               && e->ts.type == BT_CHARACTER);
153   
154   length = NULL; /* To silence compiler warning.  */
155
156   /* First candidate: if the variable is of type CHARACTER, the
157      expression's length could be the length of the character
158      variable.  */
159   if (e->symtree->n.sym->ts.type == BT_CHARACTER)
160     length = e->symtree->n.sym->ts.cl->backend_decl;
161
162   /* Look through the reference chain for component references.  */
163   for (r = e->ref; r; r = r->next)
164     {
165       switch (r->type)
166         {
167         case REF_COMPONENT:
168           if (r->u.c.component->ts.type == BT_CHARACTER)
169             length = r->u.c.component->ts.cl->backend_decl;
170           break;
171
172         case REF_ARRAY:
173           /* Do nothing.  */
174           break;
175
176         default:
177           /* We should never got substring references here.  These will be
178              broken down by the scalarizer.  */
179           gcc_unreachable ();
180         }
181     }
182
183   gcc_assert (length != NULL);
184   return length;
185 }
186
187   
188
189 /* Generate code to initialize a string length variable. Returns the
190    value.  */
191
192 void
193 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
194 {
195   gfc_se se;
196   tree tmp;
197
198   gfc_init_se (&se, NULL);
199   gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
200   gfc_add_block_to_block (pblock, &se.pre);
201
202   tmp = cl->backend_decl;
203   gfc_add_modify_expr (pblock, tmp, se.expr);
204 }
205
206
207 static void
208 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
209 {
210   tree tmp;
211   tree type;
212   tree var;
213   gfc_se start;
214   gfc_se end;
215
216   type = gfc_get_character_type (kind, ref->u.ss.length);
217   type = build_pointer_type (type);
218
219   var = NULL_TREE;
220   gfc_init_se (&start, se);
221   gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
222   gfc_add_block_to_block (&se->pre, &start.pre);
223
224   if (integer_onep (start.expr))
225     gfc_conv_string_parameter (se);
226   else
227     {
228       /* Change the start of the string.  */
229       if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
230         tmp = se->expr;
231       else
232         tmp = gfc_build_indirect_ref (se->expr);
233       tmp = gfc_build_array_ref (tmp, start.expr);
234       se->expr = gfc_build_addr_expr (type, tmp);
235     }
236
237   /* Length = end + 1 - start.  */
238   gfc_init_se (&end, se);
239   if (ref->u.ss.end == NULL)
240     end.expr = se->string_length;
241   else
242     {
243       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
244       gfc_add_block_to_block (&se->pre, &end.pre);
245     }
246   tmp =
247     build2 (MINUS_EXPR, gfc_charlen_type_node,
248             fold_convert (gfc_charlen_type_node, integer_one_node),
249             start.expr);
250   tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
251   se->string_length = fold (tmp);
252 }
253
254
255 /* Convert a derived type component reference.  */
256
257 static void
258 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
259 {
260   gfc_component *c;
261   tree tmp;
262   tree decl;
263   tree field;
264
265   c = ref->u.c.component;
266
267   gcc_assert (c->backend_decl);
268
269   field = c->backend_decl;
270   gcc_assert (TREE_CODE (field) == FIELD_DECL);
271   decl = se->expr;
272   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
273
274   se->expr = tmp;
275
276   if (c->ts.type == BT_CHARACTER)
277     {
278       tmp = c->ts.cl->backend_decl;
279       /* Components must always be constant length.  */
280       gcc_assert (tmp && INTEGER_CST_P (tmp));
281       se->string_length = tmp;
282     }
283
284   if (c->pointer && c->dimension == 0)
285     se->expr = gfc_build_indirect_ref (se->expr);
286 }
287
288
289 /* Return the contents of a variable. Also handles reference/pointer
290    variables (all Fortran pointer references are implicit).  */
291
292 static void
293 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
294 {
295   gfc_ref *ref;
296   gfc_symbol *sym;
297
298   sym = expr->symtree->n.sym;
299   if (se->ss != NULL)
300     {
301       /* Check that something hasn't gone horribly wrong.  */
302       gcc_assert (se->ss != gfc_ss_terminator);
303       gcc_assert (se->ss->expr == expr);
304
305       /* A scalarized term.  We already know the descriptor.  */
306       se->expr = se->ss->data.info.descriptor;
307       se->string_length = se->ss->string_length;
308       ref = se->ss->data.info.ref;
309     }
310   else
311     {
312       tree se_expr = NULL_TREE;
313
314       se->expr = gfc_get_symbol_decl (sym);
315
316       /* Special case for assigning the return value of a function.
317          Self recursive functions must have an explicit return value.  */
318       if (se->expr == current_function_decl && sym->attr.function
319           && (sym->result == sym))
320         se_expr = gfc_get_fake_result_decl (sym);
321
322       /* Similarly for alternate entry points.  */
323       else if (sym->attr.function && sym->attr.entry
324                && (sym->result == sym)
325                && sym->ns->proc_name->backend_decl == current_function_decl)
326         {
327           gfc_entry_list *el = NULL;
328
329           for (el = sym->ns->entries; el; el = el->next)
330             if (sym == el->sym)
331               {
332                 se_expr = gfc_get_fake_result_decl (sym);
333                 break;
334               }
335         }
336
337       else if (sym->attr.result
338                && sym->ns->proc_name->backend_decl == current_function_decl
339                && sym->ns->proc_name->attr.entry_master
340                && !gfc_return_by_reference (sym->ns->proc_name))
341         se_expr = gfc_get_fake_result_decl (sym);
342
343       if (se_expr)
344         se->expr = se_expr;
345
346       /* Procedure actual arguments.  */
347       else if (sym->attr.flavor == FL_PROCEDURE
348                && se->expr != current_function_decl)
349         {
350           gcc_assert (se->want_pointer);
351           if (!sym->attr.dummy)
352             {
353               gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
354               se->expr = gfc_build_addr_expr (NULL, se->expr);
355             }
356           return;
357         }
358
359       /* Dereference scalar dummy variables.  */
360       if (sym->attr.dummy
361           && sym->ts.type != BT_CHARACTER
362           && !sym->attr.dimension)
363         se->expr = gfc_build_indirect_ref (se->expr);
364
365       /* Dereference pointer variables.  */
366       if ((sym->attr.pointer || sym->attr.allocatable)
367           && (sym->attr.dummy
368               || sym->attr.result
369               || sym->attr.function
370               || !sym->attr.dimension)
371           && sym->ts.type != BT_CHARACTER)
372         se->expr = gfc_build_indirect_ref (se->expr);
373
374       ref = expr->ref;
375     }
376
377   /* For character variables, also get the length.  */
378   if (sym->ts.type == BT_CHARACTER)
379     {
380       se->string_length = sym->ts.cl->backend_decl;
381       gcc_assert (se->string_length);
382     }
383
384   while (ref)
385     {
386       switch (ref->type)
387         {
388         case REF_ARRAY:
389           /* Return the descriptor if that's what we want and this is an array
390              section reference.  */
391           if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
392             return;
393 /* TODO: Pointers to single elements of array sections, eg elemental subs.  */
394           /* Return the descriptor for array pointers and allocations.  */
395           if (se->want_pointer
396               && ref->next == NULL && (se->descriptor_only))
397             return;
398
399           gfc_conv_array_ref (se, &ref->u.ar);
400           /* Return a pointer to an element.  */
401           break;
402
403         case REF_COMPONENT:
404           gfc_conv_component_ref (se, ref);
405           break;
406
407         case REF_SUBSTRING:
408           gfc_conv_substring (se, ref, expr->ts.kind);
409           break;
410
411         default:
412           gcc_unreachable ();
413           break;
414         }
415       ref = ref->next;
416     }
417   /* Pointer assignment, allocation or pass by reference.  Arrays are handled
418      separately.  */
419   if (se->want_pointer)
420     {
421       if (expr->ts.type == BT_CHARACTER)
422         gfc_conv_string_parameter (se);
423       else 
424         se->expr = gfc_build_addr_expr (NULL, se->expr);
425     }
426   if (se->ss != NULL)
427     gfc_advance_se_ss_chain (se);
428 }
429
430
431 /* Unary ops are easy... Or they would be if ! was a valid op.  */
432
433 static void
434 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
435 {
436   gfc_se operand;
437   tree type;
438
439   gcc_assert (expr->ts.type != BT_CHARACTER);
440   /* Initialize the operand.  */
441   gfc_init_se (&operand, se);
442   gfc_conv_expr_val (&operand, expr->value.op.op1);
443   gfc_add_block_to_block (&se->pre, &operand.pre);
444
445   type = gfc_typenode_for_spec (&expr->ts);
446
447   /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
448      We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
449      All other unary operators have an equivalent GIMPLE unary operator.  */
450   if (code == TRUTH_NOT_EXPR)
451     se->expr = build2 (EQ_EXPR, type, operand.expr,
452                        convert (type, integer_zero_node));
453   else
454     se->expr = build1 (code, type, operand.expr);
455
456 }
457
458 /* Expand power operator to optimal multiplications when a value is raised
459    to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
460    Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
461    Programming", 3rd Edition, 1998.  */
462
463 /* This code is mostly duplicated from expand_powi in the backend.
464    We establish the "optimal power tree" lookup table with the defined size.
465    The items in the table are the exponents used to calculate the index
466    exponents. Any integer n less than the value can get an "addition chain",
467    with the first node being one.  */
468 #define POWI_TABLE_SIZE 256
469
470 /* The table is from builtins.c.  */
471 static const unsigned char powi_table[POWI_TABLE_SIZE] =
472   {
473       0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
474       4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
475       8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
476      12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
477      16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
478      20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
479      24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
480      28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
481      32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
482      36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
483      40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
484      44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
485      48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
486      52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
487      56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
488      60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
489      64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
490      68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
491      72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
492      76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
493      80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
494      84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
495      88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
496      92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
497      96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
498     100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
499     104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
500     108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
501     112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
502     116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
503     120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
504     124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
505   };
506
507 /* If n is larger than lookup table's max index, we use the "window 
508    method".  */
509 #define POWI_WINDOW_SIZE 3
510
511 /* Recursive function to expand the power operator. The temporary 
512    values are put in tmpvar. The function returns tmpvar[1] ** n.  */
513 static tree
514 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
515 {
516   tree op0;
517   tree op1;
518   tree tmp;
519   int digit;
520
521   if (n < POWI_TABLE_SIZE)
522     {
523       if (tmpvar[n])
524         return tmpvar[n];
525
526       op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
527       op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
528     }
529   else if (n & 1)
530     {
531       digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
532       op0 = gfc_conv_powi (se, n - digit, tmpvar);
533       op1 = gfc_conv_powi (se, digit, tmpvar);
534     }
535   else
536     {
537       op0 = gfc_conv_powi (se, n >> 1, tmpvar);
538       op1 = op0;
539     }
540
541   tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
542   tmp = gfc_evaluate_now (tmp, &se->pre);
543
544   if (n < POWI_TABLE_SIZE)
545     tmpvar[n] = tmp;
546
547   return tmp;
548 }
549
550
551 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
552    return 1. Else return 0 and a call to runtime library functions
553    will have to be built.  */
554 static int
555 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
556 {
557   tree cond;
558   tree tmp;
559   tree type;
560   tree vartmp[POWI_TABLE_SIZE];
561   int n;
562   int sgn;
563
564   type = TREE_TYPE (lhs);
565   n = abs (TREE_INT_CST_LOW (rhs));
566   sgn = tree_int_cst_sgn (rhs);
567
568   if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
569       && (n > 2 || n < -1))
570     return 0;
571
572   /* rhs == 0  */
573   if (sgn == 0)
574     {
575       se->expr = gfc_build_const (type, integer_one_node);
576       return 1;
577     }
578   /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
579   if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
580     {
581       tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
582                     fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
583       cond = build2 (EQ_EXPR, boolean_type_node, lhs,
584                      convert (TREE_TYPE (lhs), integer_one_node));
585
586       /* If rhs is even,
587          result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
588       if ((n & 1) == 0)
589         {
590           tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
591           se->expr = build3 (COND_EXPR, type, tmp,
592                              convert (type, integer_one_node),
593                              convert (type, integer_zero_node));
594           return 1;
595         }
596       /* If rhs is odd,
597          result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
598       tmp = build3 (COND_EXPR, type, tmp,
599                     convert (type, integer_minus_one_node),
600                     convert (type, integer_zero_node));
601       se->expr = build3 (COND_EXPR, type, cond,
602                          convert (type, integer_one_node),
603                          tmp);
604       return 1;
605     }
606
607   memset (vartmp, 0, sizeof (vartmp));
608   vartmp[1] = lhs;
609   if (sgn == -1)
610     {
611       tmp = gfc_build_const (type, integer_one_node);
612       vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
613     }
614
615   se->expr = gfc_conv_powi (se, n, vartmp);
616
617   return 1;
618 }
619
620
621 /* Power op (**).  Constant integer exponent has special handling.  */
622
623 static void
624 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
625 {
626   tree gfc_int4_type_node;
627   int kind;
628   int ikind;
629   gfc_se lse;
630   gfc_se rse;
631   tree fndecl;
632   tree tmp;
633
634   gfc_init_se (&lse, se);
635   gfc_conv_expr_val (&lse, expr->value.op.op1);
636   gfc_add_block_to_block (&se->pre, &lse.pre);
637
638   gfc_init_se (&rse, se);
639   gfc_conv_expr_val (&rse, expr->value.op.op2);
640   gfc_add_block_to_block (&se->pre, &rse.pre);
641
642   if (expr->value.op.op2->ts.type == BT_INTEGER
643          && expr->value.op.op2->expr_type == EXPR_CONSTANT)
644     if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
645       return;        
646
647   gfc_int4_type_node = gfc_get_int_type (4);
648
649   kind = expr->value.op.op1->ts.kind;
650   switch (expr->value.op.op2->ts.type)
651     {
652     case BT_INTEGER:
653       ikind = expr->value.op.op2->ts.kind;
654       switch (ikind)
655         {
656         case 1:
657         case 2:
658           rse.expr = convert (gfc_int4_type_node, rse.expr);
659           /* Fall through.  */
660
661         case 4:
662           ikind = 0;
663           break;
664           
665         case 8:
666           ikind = 1;
667           break;
668
669         default:
670           gcc_unreachable ();
671         }
672       switch (kind)
673         {
674         case 1:
675         case 2:
676           if (expr->value.op.op1->ts.type == BT_INTEGER)
677             lse.expr = convert (gfc_int4_type_node, lse.expr);
678           else
679             gcc_unreachable ();
680           /* Fall through.  */
681
682         case 4:
683           kind = 0;
684           break;
685           
686         case 8:
687           kind = 1;
688           break;
689
690         default:
691           gcc_unreachable ();
692         }
693       
694       switch (expr->value.op.op1->ts.type)
695         {
696         case BT_INTEGER:
697           fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
698           break;
699
700         case BT_REAL:
701           fndecl = gfor_fndecl_math_powi[kind][ikind].real;
702           break;
703
704         case BT_COMPLEX:
705           fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
706           break;
707
708         default:
709           gcc_unreachable ();
710         }
711       break;
712
713     case BT_REAL:
714       switch (kind)
715         {
716         case 4:
717           fndecl = built_in_decls[BUILT_IN_POWF];
718           break;
719         case 8:
720           fndecl = built_in_decls[BUILT_IN_POW];
721           break;
722         default:
723           gcc_unreachable ();
724         }
725       break;
726
727     case BT_COMPLEX:
728       switch (kind)
729         {
730         case 4:
731           fndecl = gfor_fndecl_math_cpowf;
732           break;
733         case 8:
734           fndecl = gfor_fndecl_math_cpow;
735           break;
736         default:
737           gcc_unreachable ();
738         }
739       break;
740
741     default:
742       gcc_unreachable ();
743       break;
744     }
745
746   tmp = gfc_chainon_list (NULL_TREE, lse.expr);
747   tmp = gfc_chainon_list (tmp, rse.expr);
748   se->expr = fold (gfc_build_function_call (fndecl, tmp));
749 }
750
751
752 /* Generate code to allocate a string temporary.  */
753
754 tree
755 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
756 {
757   tree var;
758   tree tmp;
759   tree args;
760
761   gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
762
763   if (gfc_can_put_var_on_stack (len))
764     {
765       /* Create a temporary variable to hold the result.  */
766       tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
767                          convert (gfc_charlen_type_node, integer_one_node));
768       tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
769       tmp = build_array_type (gfc_character1_type_node, tmp);
770       var = gfc_create_var (tmp, "str");
771       var = gfc_build_addr_expr (type, var);
772     }
773   else
774     {
775       /* Allocate a temporary to hold the result.  */
776       var = gfc_create_var (type, "pstr");
777       args = gfc_chainon_list (NULL_TREE, len);
778       tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
779       tmp = convert (type, tmp);
780       gfc_add_modify_expr (&se->pre, var, tmp);
781
782       /* Free the temporary afterwards.  */
783       tmp = convert (pvoid_type_node, var);
784       args = gfc_chainon_list (NULL_TREE, tmp);
785       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
786       gfc_add_expr_to_block (&se->post, tmp);
787     }
788
789   return var;
790 }
791
792
793 /* Handle a string concatenation operation.  A temporary will be allocated to
794    hold the result.  */
795
796 static void
797 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
798 {
799   gfc_se lse;
800   gfc_se rse;
801   tree len;
802   tree type;
803   tree var;
804   tree args;
805   tree tmp;
806
807   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
808           && expr->value.op.op2->ts.type == BT_CHARACTER);
809
810   gfc_init_se (&lse, se);
811   gfc_conv_expr (&lse, expr->value.op.op1);
812   gfc_conv_string_parameter (&lse);
813   gfc_init_se (&rse, se);
814   gfc_conv_expr (&rse, expr->value.op.op2);
815   gfc_conv_string_parameter (&rse);
816
817   gfc_add_block_to_block (&se->pre, &lse.pre);
818   gfc_add_block_to_block (&se->pre, &rse.pre);
819
820   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
821   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
822   if (len == NULL_TREE)
823     {
824       len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
825                          lse.string_length, rse.string_length);
826     }
827
828   type = build_pointer_type (type);
829
830   var = gfc_conv_string_tmp (se, type, len);
831
832   /* Do the actual concatenation.  */
833   args = NULL_TREE;
834   args = gfc_chainon_list (args, len);
835   args = gfc_chainon_list (args, var);
836   args = gfc_chainon_list (args, lse.string_length);
837   args = gfc_chainon_list (args, lse.expr);
838   args = gfc_chainon_list (args, rse.string_length);
839   args = gfc_chainon_list (args, rse.expr);
840   tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
841   gfc_add_expr_to_block (&se->pre, tmp);
842
843   /* Add the cleanup for the operands.  */
844   gfc_add_block_to_block (&se->pre, &rse.post);
845   gfc_add_block_to_block (&se->pre, &lse.post);
846
847   se->expr = var;
848   se->string_length = len;
849 }
850
851
852 /* Translates an op expression. Common (binary) cases are handled by this
853    function, others are passed on. Recursion is used in either case.
854    We use the fact that (op1.ts == op2.ts) (except for the power
855    operator **).
856    Operators need no special handling for scalarized expressions as long as
857    they call gfc_conv_simple_val to get their operands.
858    Character strings get special handling.  */
859
860 static void
861 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
862 {
863   enum tree_code code;
864   gfc_se lse;
865   gfc_se rse;
866   tree type;
867   tree tmp;
868   int lop;
869   int checkstring;
870
871   checkstring = 0;
872   lop = 0;
873   switch (expr->value.op.operator)
874     {
875     case INTRINSIC_UPLUS:
876       gfc_conv_expr (se, expr->value.op.op1);
877       return;
878
879     case INTRINSIC_UMINUS:
880       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
881       return;
882
883     case INTRINSIC_NOT:
884       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
885       return;
886
887     case INTRINSIC_PLUS:
888       code = PLUS_EXPR;
889       break;
890
891     case INTRINSIC_MINUS:
892       code = MINUS_EXPR;
893       break;
894
895     case INTRINSIC_TIMES:
896       code = MULT_EXPR;
897       break;
898
899     case INTRINSIC_DIVIDE:
900       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
901          an integer, we must round towards zero, so we use a
902          TRUNC_DIV_EXPR.  */
903       if (expr->ts.type == BT_INTEGER)
904         code = TRUNC_DIV_EXPR;
905       else
906         code = RDIV_EXPR;
907       break;
908
909     case INTRINSIC_POWER:
910       gfc_conv_power_op (se, expr);
911       return;
912
913     case INTRINSIC_CONCAT:
914       gfc_conv_concat_op (se, expr);
915       return;
916
917     case INTRINSIC_AND:
918       code = TRUTH_ANDIF_EXPR;
919       lop = 1;
920       break;
921
922     case INTRINSIC_OR:
923       code = TRUTH_ORIF_EXPR;
924       lop = 1;
925       break;
926
927       /* EQV and NEQV only work on logicals, but since we represent them
928          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
929     case INTRINSIC_EQ:
930     case INTRINSIC_EQV:
931       code = EQ_EXPR;
932       checkstring = 1;
933       lop = 1;
934       break;
935
936     case INTRINSIC_NE:
937     case INTRINSIC_NEQV:
938       code = NE_EXPR;
939       checkstring = 1;
940       lop = 1;
941       break;
942
943     case INTRINSIC_GT:
944       code = GT_EXPR;
945       checkstring = 1;
946       lop = 1;
947       break;
948
949     case INTRINSIC_GE:
950       code = GE_EXPR;
951       checkstring = 1;
952       lop = 1;
953       break;
954
955     case INTRINSIC_LT:
956       code = LT_EXPR;
957       checkstring = 1;
958       lop = 1;
959       break;
960
961     case INTRINSIC_LE:
962       code = LE_EXPR;
963       checkstring = 1;
964       lop = 1;
965       break;
966
967     case INTRINSIC_USER:
968     case INTRINSIC_ASSIGN:
969       /* These should be converted into function calls by the frontend.  */
970       gcc_unreachable ();
971
972     default:
973       fatal_error ("Unknown intrinsic op");
974       return;
975     }
976
977   /* The only exception to this is **, which is handled separately anyway.  */
978   gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
979
980   if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
981     checkstring = 0;
982
983   /* lhs */
984   gfc_init_se (&lse, se);
985   gfc_conv_expr (&lse, expr->value.op.op1);
986   gfc_add_block_to_block (&se->pre, &lse.pre);
987
988   /* rhs */
989   gfc_init_se (&rse, se);
990   gfc_conv_expr (&rse, expr->value.op.op2);
991   gfc_add_block_to_block (&se->pre, &rse.pre);
992
993   /* For string comparisons we generate a library call, and compare the return
994      value with 0.  */
995   if (checkstring)
996     {
997       gfc_conv_string_parameter (&lse);
998       gfc_conv_string_parameter (&rse);
999       tmp = NULL_TREE;
1000       tmp = gfc_chainon_list (tmp, lse.string_length);
1001       tmp = gfc_chainon_list (tmp, lse.expr);
1002       tmp = gfc_chainon_list (tmp, rse.string_length);
1003       tmp = gfc_chainon_list (tmp, rse.expr);
1004
1005       /* Build a call for the comparison.  */
1006       lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1007       gfc_add_block_to_block (&lse.post, &rse.post);
1008
1009       rse.expr = integer_zero_node;
1010     }
1011
1012   type = gfc_typenode_for_spec (&expr->ts);
1013
1014   if (lop)
1015     {
1016       /* The result of logical ops is always boolean_type_node.  */
1017       tmp = fold_build2 (code, type, lse.expr, rse.expr);
1018       se->expr = convert (type, tmp);
1019     }
1020   else
1021     se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1022
1023   /* Add the post blocks.  */
1024   gfc_add_block_to_block (&se->post, &rse.post);
1025   gfc_add_block_to_block (&se->post, &lse.post);
1026 }
1027
1028
1029 static void
1030 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1031 {
1032   tree tmp;
1033
1034   if (sym->attr.dummy)
1035     {
1036       tmp = gfc_get_symbol_decl (sym);
1037       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1038               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1039
1040       se->expr = tmp;
1041     }
1042   else
1043     {
1044       if (!sym->backend_decl)
1045         sym->backend_decl = gfc_get_extern_function_decl (sym);
1046
1047       tmp = sym->backend_decl;
1048       gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1049       se->expr = gfc_build_addr_expr (NULL, tmp);
1050     }
1051 }
1052
1053
1054 /* Generate code for a procedure call.  Note can return se->post != NULL.
1055    If se->direct_byref is set then se->expr contains the return parameter.  */
1056
1057 void
1058 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1059                         gfc_actual_arglist * arg)
1060 {
1061   tree arglist;
1062   tree tmp;
1063   tree fntype;
1064   gfc_se parmse;
1065   gfc_ss *argss;
1066   gfc_ss_info *info;
1067   int byref;
1068   tree type;
1069   tree var;
1070   tree len;
1071   tree stringargs;
1072   gfc_formal_arglist *formal;
1073
1074   arglist = NULL_TREE;
1075   stringargs = NULL_TREE;
1076   var = NULL_TREE;
1077   len = NULL_TREE;
1078
1079   if (se->ss != NULL)
1080     {
1081       if (!sym->attr.elemental)
1082         {
1083           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1084           if (se->ss->useflags)
1085             {
1086               gcc_assert (gfc_return_by_reference (sym)
1087                       && sym->result->attr.dimension);
1088               gcc_assert (se->loop != NULL);
1089
1090               /* Access the previously obtained result.  */
1091               gfc_conv_tmp_array_ref (se);
1092               gfc_advance_se_ss_chain (se);
1093               return;
1094             }
1095         }
1096       info = &se->ss->data.info;
1097     }
1098   else
1099     info = NULL;
1100
1101   byref = gfc_return_by_reference (sym);
1102   if (byref)
1103     {
1104       if (se->direct_byref)
1105         arglist = gfc_chainon_list (arglist, se->expr);
1106       else if (sym->result->attr.dimension)
1107         {
1108           gcc_assert (se->loop && se->ss);
1109           /* Set the type of the array.  */
1110           tmp = gfc_typenode_for_spec (&sym->ts);
1111           info->dimen = se->loop->dimen;
1112           /* Allocate a temporary to store the result.  */
1113           gfc_trans_allocate_temp_array (se->loop, info, tmp);
1114
1115           /* Zero the first stride to indicate a temporary.  */
1116           tmp =
1117             gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1118           gfc_add_modify_expr (&se->pre, tmp,
1119                                convert (TREE_TYPE (tmp), integer_zero_node));
1120           /* Pass the temporary as the first argument.  */
1121           tmp = info->descriptor;
1122           tmp = gfc_build_addr_expr (NULL, tmp);
1123           arglist = gfc_chainon_list (arglist, tmp);
1124         }
1125       else if (sym->ts.type == BT_CHARACTER)
1126         {
1127           gcc_assert (sym->ts.cl && sym->ts.cl->length
1128                   && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1129           len = gfc_conv_mpz_to_tree
1130             (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1131           sym->ts.cl->backend_decl = len;
1132           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1133           type = build_pointer_type (type);
1134
1135           var = gfc_conv_string_tmp (se, type, len);
1136           arglist = gfc_chainon_list (arglist, var);
1137           arglist = gfc_chainon_list (arglist, 
1138                                       convert (gfc_charlen_type_node, len));
1139         }
1140       else
1141         gcc_unreachable ();
1142     }
1143
1144   formal = sym->formal;
1145   /* Evaluate the arguments.  */
1146   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1147     {
1148       if (arg->expr == NULL)
1149         {
1150
1151           if (se->ignore_optional)
1152             {
1153               /* Some intrinsics have already been resolved to the correct
1154                  parameters.  */
1155               continue;
1156             }
1157           else if (arg->label)
1158             {
1159               has_alternate_specifier = 1;
1160               continue;
1161             }
1162           else
1163             {
1164               /* Pass a NULL pointer for an absent arg.  */
1165               gfc_init_se (&parmse, NULL);
1166               parmse.expr = null_pointer_node;
1167               if (arg->missing_arg_type == BT_CHARACTER)
1168                 {
1169                   stringargs =
1170                     gfc_chainon_list (stringargs,
1171                                       convert (gfc_charlen_type_node,
1172                                                integer_zero_node));
1173                 }
1174             }
1175         }
1176       else if (se->ss && se->ss->useflags)
1177         {
1178           /* An elemental function inside a scalarized loop.  */
1179           gfc_init_se (&parmse, se);
1180           gfc_conv_expr_reference (&parmse, arg->expr);
1181         }
1182       else
1183         {
1184           /* A scalar or transformational function.  */
1185           gfc_init_se (&parmse, NULL);
1186           argss = gfc_walk_expr (arg->expr);
1187
1188           if (argss == gfc_ss_terminator)
1189             {
1190               gfc_conv_expr_reference (&parmse, arg->expr);
1191               if (formal && formal->sym->attr.pointer
1192                   && arg->expr->expr_type != EXPR_NULL)
1193                 {
1194                   /* Scalar pointer dummy args require an extra level of
1195                      indirection. The null pointer already contains
1196                      this level of indirection.  */
1197                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1198                 }
1199             }
1200           else
1201             {
1202               /* If the procedure requires an explicit interface, the
1203                  actual argument is passed according to the
1204                  corresponding formal argument.  If the corresponding
1205                  formal argument is a POINTER or assumed shape, we do
1206                  not use g77's calling convention, and pass the
1207                  address of the array descriptor instead. Otherwise we
1208                  use g77's calling convention.  */
1209               int f;
1210               f = (formal != NULL)
1211                   && !formal->sym->attr.pointer
1212                   && formal->sym->as->type != AS_ASSUMED_SHAPE;
1213               f = f || !sym->attr.always_explicit;
1214               gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1215             } 
1216         }
1217
1218       gfc_add_block_to_block (&se->pre, &parmse.pre);
1219       gfc_add_block_to_block (&se->post, &parmse.post);
1220
1221       /* Character strings are passed as two parameters, a length and a
1222          pointer.  */
1223       if (parmse.string_length != NULL_TREE)
1224         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1225
1226       arglist = gfc_chainon_list (arglist, parmse.expr);
1227     }
1228
1229   /* Add the hidden string length parameters to the arguments.  */
1230   arglist = chainon (arglist, stringargs);
1231
1232   /* Generate the actual call.  */
1233   gfc_conv_function_val (se, sym);
1234   /* If there are alternate return labels, function type should be
1235      integer.  */
1236   if (has_alternate_specifier)
1237     TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1238
1239   fntype = TREE_TYPE (TREE_TYPE (se->expr));
1240   se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1241                      arglist, NULL_TREE);
1242
1243   /* If we have a pointer function, but we don't want a pointer, e.g.
1244      something like
1245         x = f()
1246      where f is pointer valued, we have to dereference the result.  */
1247   if (!se->want_pointer && !byref
1248       && (sym->attr.pointer || (sym->result && sym->result->attr.pointer)))
1249     se->expr = gfc_build_indirect_ref (se->expr);
1250
1251   /* A pure function may still have side-effects - it may modify its
1252      parameters.  */
1253   TREE_SIDE_EFFECTS (se->expr) = 1;
1254 #if 0
1255   if (!sym->attr.pure)
1256     TREE_SIDE_EFFECTS (se->expr) = 1;
1257 #endif
1258
1259   if (byref)
1260     {
1261       /* Add the function call to the pre chain.  There is no expression.  */
1262       gfc_add_expr_to_block (&se->pre, se->expr);
1263       se->expr = NULL_TREE;
1264
1265       if (!se->direct_byref)
1266         {
1267           if (sym->result->attr.dimension)
1268             {
1269               if (flag_bounds_check)
1270                 {
1271                   /* Check the data pointer hasn't been modified.  This would
1272                      happen in a function returning a pointer.  */
1273                   tmp = gfc_conv_descriptor_data (info->descriptor);
1274                   tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1275                   gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1276                 }
1277               se->expr = info->descriptor;
1278             }
1279           else if (sym->ts.type == BT_CHARACTER)
1280             {
1281               se->expr = var;
1282               se->string_length = len;
1283             }
1284           else
1285             gcc_unreachable ();
1286         }
1287     }
1288 }
1289
1290
1291 /* Generate code to copy a string.  */
1292
1293 static void
1294 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1295                        tree slen, tree src)
1296 {
1297   tree tmp;
1298
1299   tmp = NULL_TREE;
1300   tmp = gfc_chainon_list (tmp, dlen);
1301   tmp = gfc_chainon_list (tmp, dest);
1302   tmp = gfc_chainon_list (tmp, slen);
1303   tmp = gfc_chainon_list (tmp, src);
1304   tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1305   gfc_add_expr_to_block (block, tmp);
1306 }
1307
1308
1309 /* Translate a statement function.
1310    The value of a statement function reference is obtained by evaluating the
1311    expression using the values of the actual arguments for the values of the
1312    corresponding dummy arguments.  */
1313
1314 static void
1315 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1316 {
1317   gfc_symbol *sym;
1318   gfc_symbol *fsym;
1319   gfc_formal_arglist *fargs;
1320   gfc_actual_arglist *args;
1321   gfc_se lse;
1322   gfc_se rse;
1323   gfc_saved_var *saved_vars;
1324   tree *temp_vars;
1325   tree type;
1326   tree tmp;
1327   int n;
1328
1329   sym = expr->symtree->n.sym;
1330   args = expr->value.function.actual;
1331   gfc_init_se (&lse, NULL);
1332   gfc_init_se (&rse, NULL);
1333
1334   n = 0;
1335   for (fargs = sym->formal; fargs; fargs = fargs->next)
1336     n++;
1337   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1338   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1339
1340   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1341     {
1342       /* Each dummy shall be specified, explicitly or implicitly, to be
1343          scalar.  */
1344       gcc_assert (fargs->sym->attr.dimension == 0);
1345       fsym = fargs->sym;
1346
1347       /* Create a temporary to hold the value.  */
1348       type = gfc_typenode_for_spec (&fsym->ts);
1349       temp_vars[n] = gfc_create_var (type, fsym->name);
1350
1351       if (fsym->ts.type == BT_CHARACTER)
1352         {
1353           /* Copy string arguments.  */
1354           tree arglen;
1355
1356           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1357                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1358
1359           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1360           tmp = gfc_build_addr_expr (build_pointer_type (type),
1361                                      temp_vars[n]);
1362
1363           gfc_conv_expr (&rse, args->expr);
1364           gfc_conv_string_parameter (&rse);
1365           gfc_add_block_to_block (&se->pre, &lse.pre);
1366           gfc_add_block_to_block (&se->pre, &rse.pre);
1367
1368           gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1369                                  rse.expr);
1370           gfc_add_block_to_block (&se->pre, &lse.post);
1371           gfc_add_block_to_block (&se->pre, &rse.post);
1372         }
1373       else
1374         {
1375           /* For everything else, just evaluate the expression.  */
1376           gfc_conv_expr (&lse, args->expr);
1377
1378           gfc_add_block_to_block (&se->pre, &lse.pre);
1379           gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1380           gfc_add_block_to_block (&se->pre, &lse.post);
1381         }
1382
1383       args = args->next;
1384     }
1385
1386   /* Use the temporary variables in place of the real ones.  */
1387   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1388     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1389
1390   gfc_conv_expr (se, sym->value);
1391
1392   if (sym->ts.type == BT_CHARACTER)
1393     {
1394       gfc_conv_const_charlen (sym->ts.cl);
1395
1396       /* Force the expression to the correct length.  */
1397       if (!INTEGER_CST_P (se->string_length)
1398           || tree_int_cst_lt (se->string_length,
1399                               sym->ts.cl->backend_decl))
1400         {
1401           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1402           tmp = gfc_create_var (type, sym->name);
1403           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1404           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1405                                  se->string_length, se->expr);
1406           se->expr = tmp;
1407         }
1408       se->string_length = sym->ts.cl->backend_decl;
1409     }
1410
1411   /* Restore the original variables.  */
1412   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1413     gfc_restore_sym (fargs->sym, &saved_vars[n]);
1414   gfc_free (saved_vars);
1415 }
1416
1417
1418 /* Translate a function expression.  */
1419
1420 static void
1421 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1422 {
1423   gfc_symbol *sym;
1424
1425   if (expr->value.function.isym)
1426     {
1427       gfc_conv_intrinsic_function (se, expr);
1428       return;
1429     }
1430
1431   /* We distinguish statement functions from general functions to improve
1432      runtime performance.  */
1433   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1434     {
1435       gfc_conv_statement_function (se, expr);
1436       return;
1437     }
1438
1439   /* expr.value.function.esym is the resolved (specific) function symbol for
1440      most functions.  However this isn't set for dummy procedures.  */
1441   sym = expr->value.function.esym;
1442   if (!sym)
1443     sym = expr->symtree->n.sym;
1444   gfc_conv_function_call (se, sym, expr->value.function.actual);
1445 }
1446
1447
1448 static void
1449 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1450 {
1451   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1452   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1453
1454   gfc_conv_tmp_array_ref (se);
1455   gfc_advance_se_ss_chain (se);
1456 }
1457
1458
1459 /* Build a static initializer.  EXPR is the expression for the initial value.
1460    The other parameters describe the variable of the component being 
1461    initialized. EXPR may be null.  */
1462
1463 tree
1464 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1465                       bool array, bool pointer)
1466 {
1467   gfc_se se;
1468
1469   if (!(expr || pointer))
1470     return NULL_TREE;
1471
1472   if (array)
1473     {
1474       /* Arrays need special handling.  */
1475       if (pointer)
1476         return gfc_build_null_descriptor (type);
1477       else
1478         return gfc_conv_array_initializer (type, expr);
1479     }
1480   else if (pointer)
1481     return fold_convert (type, null_pointer_node);
1482   else
1483     {
1484       switch (ts->type)
1485         {
1486         case BT_DERIVED:
1487           gfc_init_se (&se, NULL);
1488           gfc_conv_structure (&se, expr, 1);
1489           return se.expr;
1490
1491         case BT_CHARACTER:
1492           return gfc_conv_string_init (ts->cl->backend_decl,expr);
1493
1494         default:
1495           gfc_init_se (&se, NULL);
1496           gfc_conv_constant (&se, expr);
1497           return se.expr;
1498         }
1499     }
1500 }
1501   
1502 static tree
1503 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1504 {
1505   gfc_se rse;
1506   gfc_se lse;
1507   gfc_ss *rss;
1508   gfc_ss *lss;
1509   stmtblock_t body;
1510   stmtblock_t block;
1511   gfc_loopinfo loop;
1512   int n;
1513   tree tmp;
1514
1515   gfc_start_block (&block);
1516
1517   /* Initialize the scalarizer.  */
1518   gfc_init_loopinfo (&loop);
1519
1520   gfc_init_se (&lse, NULL);
1521   gfc_init_se (&rse, NULL);
1522
1523   /* Walk the rhs.  */
1524   rss = gfc_walk_expr (expr);
1525   if (rss == gfc_ss_terminator)
1526     {
1527       /* The rhs is scalar.  Add a ss for the expression.  */
1528       rss = gfc_get_ss ();
1529       rss->next = gfc_ss_terminator;
1530       rss->type = GFC_SS_SCALAR;
1531       rss->expr = expr;
1532     }
1533
1534   /* Create a SS for the destination.  */
1535   lss = gfc_get_ss ();
1536   lss->type = GFC_SS_COMPONENT;
1537   lss->expr = NULL;
1538   lss->shape = gfc_get_shape (cm->as->rank);
1539   lss->next = gfc_ss_terminator;
1540   lss->data.info.dimen = cm->as->rank;
1541   lss->data.info.descriptor = dest;
1542   lss->data.info.data = gfc_conv_array_data (dest);
1543   lss->data.info.offset = gfc_conv_array_offset (dest);
1544   for (n = 0; n < cm->as->rank; n++)
1545     {
1546       lss->data.info.dim[n] = n;
1547       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1548       lss->data.info.stride[n] = gfc_index_one_node;
1549
1550       mpz_init (lss->shape[n]);
1551       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1552                cm->as->lower[n]->value.integer);
1553       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1554     }
1555   
1556   /* Associate the SS with the loop.  */
1557   gfc_add_ss_to_loop (&loop, lss);
1558   gfc_add_ss_to_loop (&loop, rss);
1559
1560   /* Calculate the bounds of the scalarization.  */
1561   gfc_conv_ss_startstride (&loop);
1562
1563   /* Setup the scalarizing loops.  */
1564   gfc_conv_loop_setup (&loop);
1565
1566   /* Setup the gfc_se structures.  */
1567   gfc_copy_loopinfo_to_se (&lse, &loop);
1568   gfc_copy_loopinfo_to_se (&rse, &loop);
1569
1570   rse.ss = rss;
1571   gfc_mark_ss_chain_used (rss, 1);
1572   lse.ss = lss;
1573   gfc_mark_ss_chain_used (lss, 1);
1574
1575   /* Start the scalarized loop body.  */
1576   gfc_start_scalarized_body (&loop, &body);
1577
1578   gfc_conv_tmp_array_ref (&lse);
1579   gfc_conv_expr (&rse, expr);
1580
1581   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1582   gfc_add_expr_to_block (&body, tmp);
1583
1584   gcc_assert (rse.ss == gfc_ss_terminator);
1585
1586   /* Generate the copying loops.  */
1587   gfc_trans_scalarizing_loops (&loop, &body);
1588
1589   /* Wrap the whole thing up.  */
1590   gfc_add_block_to_block (&block, &loop.pre);
1591   gfc_add_block_to_block (&block, &loop.post);
1592
1593   for (n = 0; n < cm->as->rank; n++)
1594     mpz_clear (lss->shape[n]);
1595   gfc_free (lss->shape);
1596
1597   gfc_cleanup_loop (&loop);
1598
1599   return gfc_finish_block (&block);
1600 }
1601
1602 /* Assign a single component of a derived type constructor.  */
1603
1604 static tree
1605 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1606 {
1607   gfc_se se;
1608   gfc_ss *rss;
1609   stmtblock_t block;
1610   tree tmp;
1611
1612   gfc_start_block (&block);
1613   if (cm->pointer)
1614     {
1615       gfc_init_se (&se, NULL);
1616       /* Pointer component.  */
1617       if (cm->dimension)
1618         {
1619           /* Array pointer.  */
1620           if (expr->expr_type == EXPR_NULL)
1621             {
1622               dest = gfc_conv_descriptor_data (dest);
1623               tmp = fold_convert (TREE_TYPE (se.expr),
1624                                   null_pointer_node);
1625               gfc_add_modify_expr (&block, dest, tmp);
1626             }
1627           else
1628             {
1629               rss = gfc_walk_expr (expr);
1630               se.direct_byref = 1;
1631               se.expr = dest;
1632               gfc_conv_expr_descriptor (&se, expr, rss);
1633               gfc_add_block_to_block (&block, &se.pre);
1634               gfc_add_block_to_block (&block, &se.post);
1635             }
1636         }
1637       else
1638         {
1639           /* Scalar pointers.  */
1640           se.want_pointer = 1;
1641           gfc_conv_expr (&se, expr);
1642           gfc_add_block_to_block (&block, &se.pre);
1643           gfc_add_modify_expr (&block, dest,
1644                                fold_convert (TREE_TYPE (dest), se.expr));
1645           gfc_add_block_to_block (&block, &se.post);
1646         }
1647     }
1648   else if (cm->dimension)
1649     {
1650       tmp = gfc_trans_subarray_assign (dest, cm, expr);
1651       gfc_add_expr_to_block (&block, tmp);
1652     }
1653   else if (expr->ts.type == BT_DERIVED)
1654     {
1655       /* Nested derived type.  */
1656       tmp = gfc_trans_structure_assign (dest, expr);
1657       gfc_add_expr_to_block (&block, tmp);
1658     }
1659   else
1660     {
1661       /* Scalar component.  */
1662       gfc_se lse;
1663
1664       gfc_init_se (&se, NULL);
1665       gfc_init_se (&lse, NULL);
1666
1667       gfc_conv_expr (&se, expr);
1668       if (cm->ts.type == BT_CHARACTER)
1669         lse.string_length = cm->ts.cl->backend_decl;
1670       lse.expr = dest;
1671       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1672       gfc_add_expr_to_block (&block, tmp);
1673     }
1674   return gfc_finish_block (&block);
1675 }
1676
1677 /* Assign a derived type constructor to a variable.  */
1678
1679 static tree
1680 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1681 {
1682   gfc_constructor *c;
1683   gfc_component *cm;
1684   stmtblock_t block;
1685   tree field;
1686   tree tmp;
1687
1688   gfc_start_block (&block);
1689   cm = expr->ts.derived->components;
1690   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1691     {
1692       /* Skip absent members in default initializers.  */
1693       if (!c->expr)
1694         continue;
1695
1696       field = cm->backend_decl;
1697       tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1698       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1699       gfc_add_expr_to_block (&block, tmp);
1700     }
1701   return gfc_finish_block (&block);
1702 }
1703
1704 /* Build an expression for a constructor. If init is nonzero then
1705    this is part of a static variable initializer.  */
1706
1707 void
1708 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1709 {
1710   gfc_constructor *c;
1711   gfc_component *cm;
1712   tree head;
1713   tree tail;
1714   tree val;
1715   tree type;
1716   tree tmp;
1717
1718   gcc_assert (se->ss == NULL);
1719   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1720   type = gfc_typenode_for_spec (&expr->ts);
1721
1722   if (!init)
1723     {
1724       /* Create a temporary variable and fill it in.  */
1725       se->expr = gfc_create_var (type, expr->ts.derived->name);
1726       tmp = gfc_trans_structure_assign (se->expr, expr);
1727       gfc_add_expr_to_block (&se->pre, tmp);
1728       return;
1729     }
1730
1731   head = build1 (CONSTRUCTOR, type, NULL_TREE);
1732   tail = NULL_TREE;
1733
1734   cm = expr->ts.derived->components;
1735   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1736     {
1737       /* Skip absent members in default initializers.  */
1738       if (!c->expr)
1739         continue;
1740
1741       val = gfc_conv_initializer (c->expr, &cm->ts,
1742           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1743
1744       /* Build a TREE_CHAIN to hold it.  */
1745       val = tree_cons (cm->backend_decl, val, NULL_TREE);
1746
1747       /* Add it to the list.  */
1748       if (tail == NULL_TREE)
1749         TREE_OPERAND(head, 0) = tail = val;
1750       else
1751         {
1752           TREE_CHAIN (tail) = val;
1753           tail = val;
1754         }
1755     }
1756   se->expr = head;
1757 }
1758
1759
1760 /* Translate a substring expression.  */
1761
1762 static void
1763 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1764 {
1765   gfc_ref *ref;
1766
1767   ref = expr->ref;
1768
1769   gcc_assert (ref->type == REF_SUBSTRING);
1770
1771   se->expr = gfc_build_string_const(expr->value.character.length,
1772                                     expr->value.character.string);
1773   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1774   TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1775
1776   gfc_conv_substring(se,ref,expr->ts.kind);
1777 }
1778
1779
1780 /* Entry point for expression translation.  */
1781
1782 void
1783 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1784 {
1785   if (se->ss && se->ss->expr == expr
1786       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1787     {
1788       /* Substitute a scalar expression evaluated outside the scalarization
1789          loop.  */
1790       se->expr = se->ss->data.scalar.expr;
1791       se->string_length = se->ss->string_length;
1792       gfc_advance_se_ss_chain (se);
1793       return;
1794     }
1795
1796   switch (expr->expr_type)
1797     {
1798     case EXPR_OP:
1799       gfc_conv_expr_op (se, expr);
1800       break;
1801
1802     case EXPR_FUNCTION:
1803       gfc_conv_function_expr (se, expr);
1804       break;
1805
1806     case EXPR_CONSTANT:
1807       gfc_conv_constant (se, expr);
1808       break;
1809
1810     case EXPR_VARIABLE:
1811       gfc_conv_variable (se, expr);
1812       break;
1813
1814     case EXPR_NULL:
1815       se->expr = null_pointer_node;
1816       break;
1817
1818     case EXPR_SUBSTRING:
1819       gfc_conv_substring_expr (se, expr);
1820       break;
1821
1822     case EXPR_STRUCTURE:
1823       gfc_conv_structure (se, expr, 0);
1824       break;
1825
1826     case EXPR_ARRAY:
1827       gfc_conv_array_constructor_expr (se, expr);
1828       break;
1829
1830     default:
1831       gcc_unreachable ();
1832       break;
1833     }
1834 }
1835
1836 void
1837 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1838 {
1839   gfc_conv_expr (se, expr);
1840   /* AFAICS all numeric lvalues have empty post chains.  If not we need to
1841      figure out a way of rewriting an lvalue so that it has no post chain.  */
1842   gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1843 }
1844
1845 void
1846 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1847 {
1848   tree val;
1849
1850   gcc_assert (expr->ts.type != BT_CHARACTER);
1851   gfc_conv_expr (se, expr);
1852   if (se->post.head)
1853     {
1854       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1855       gfc_add_modify_expr (&se->pre, val, se->expr);
1856     }
1857 }
1858
1859 void
1860 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1861 {
1862   gfc_conv_expr_val (se, expr);
1863   se->expr = convert (type, se->expr);
1864 }
1865
1866
1867 /* Converts an expression so that it can be passed by reference.  Scalar
1868    values only.  */
1869
1870 void
1871 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1872 {
1873   tree var;
1874
1875   if (se->ss && se->ss->expr == expr
1876       && se->ss->type == GFC_SS_REFERENCE)
1877     {
1878       se->expr = se->ss->data.scalar.expr;
1879       se->string_length = se->ss->string_length;
1880       gfc_advance_se_ss_chain (se);
1881       return;
1882     }
1883
1884   if (expr->ts.type == BT_CHARACTER)
1885     {
1886       gfc_conv_expr (se, expr);
1887       gfc_conv_string_parameter (se);
1888       return;
1889     }
1890
1891   if (expr->expr_type == EXPR_VARIABLE)
1892     {
1893       se->want_pointer = 1;
1894       gfc_conv_expr (se, expr);
1895       if (se->post.head)
1896         {
1897           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1898           gfc_add_modify_expr (&se->pre, var, se->expr);
1899           gfc_add_block_to_block (&se->pre, &se->post);
1900           se->expr = var;
1901         }
1902       return;
1903     }
1904
1905   gfc_conv_expr (se, expr);
1906
1907   /* Create a temporary var to hold the value.  */
1908   if (TREE_CONSTANT (se->expr))
1909     {
1910       var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1911       DECL_INITIAL (var) = se->expr;
1912       pushdecl (var);
1913     }
1914   else
1915     {
1916       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1917       gfc_add_modify_expr (&se->pre, var, se->expr);
1918     }
1919   gfc_add_block_to_block (&se->pre, &se->post);
1920
1921   /* Take the address of that value.  */
1922   se->expr = gfc_build_addr_expr (NULL, var);
1923 }
1924
1925
1926 tree
1927 gfc_trans_pointer_assign (gfc_code * code)
1928 {
1929   return gfc_trans_pointer_assignment (code->expr, code->expr2);
1930 }
1931
1932
1933 /* Generate code for a pointer assignment.  */
1934
1935 tree
1936 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1937 {
1938   gfc_se lse;
1939   gfc_se rse;
1940   gfc_ss *lss;
1941   gfc_ss *rss;
1942   stmtblock_t block;
1943
1944   gfc_start_block (&block);
1945
1946   gfc_init_se (&lse, NULL);
1947
1948   lss = gfc_walk_expr (expr1);
1949   rss = gfc_walk_expr (expr2);
1950   if (lss == gfc_ss_terminator)
1951     {
1952       /* Scalar pointers.  */
1953       lse.want_pointer = 1;
1954       gfc_conv_expr (&lse, expr1);
1955       gcc_assert (rss == gfc_ss_terminator);
1956       gfc_init_se (&rse, NULL);
1957       rse.want_pointer = 1;
1958       gfc_conv_expr (&rse, expr2);
1959       gfc_add_block_to_block (&block, &lse.pre);
1960       gfc_add_block_to_block (&block, &rse.pre);
1961       gfc_add_modify_expr (&block, lse.expr,
1962                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
1963       gfc_add_block_to_block (&block, &rse.post);
1964       gfc_add_block_to_block (&block, &lse.post);
1965     }
1966   else
1967     {
1968       /* Array pointer.  */
1969       gfc_conv_expr_descriptor (&lse, expr1, lss);
1970       /* Implement Nullify.  */
1971       if (expr2->expr_type == EXPR_NULL)
1972         {
1973           lse.expr = gfc_conv_descriptor_data (lse.expr);
1974           rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1975           gfc_add_modify_expr (&block, lse.expr, rse.expr);
1976         }
1977       else
1978         {
1979           lse.direct_byref = 1;
1980           gfc_conv_expr_descriptor (&lse, expr2, rss);
1981         }
1982       gfc_add_block_to_block (&block, &lse.pre);
1983       gfc_add_block_to_block (&block, &lse.post);
1984     }
1985   return gfc_finish_block (&block);
1986 }
1987
1988
1989 /* Makes sure se is suitable for passing as a function string parameter.  */
1990 /* TODO: Need to check all callers fo this function.  It may be abused.  */
1991
1992 void
1993 gfc_conv_string_parameter (gfc_se * se)
1994 {
1995   tree type;
1996
1997   if (TREE_CODE (se->expr) == STRING_CST)
1998     {
1999       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2000       return;
2001     }
2002
2003   type = TREE_TYPE (se->expr);
2004   if (TYPE_STRING_FLAG (type))
2005     {
2006       gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2007       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2008     }
2009
2010   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2011   gcc_assert (se->string_length
2012           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2013 }
2014
2015
2016 /* Generate code for assignment of scalar variables.  Includes character
2017    strings.  */
2018
2019 tree
2020 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2021 {
2022   stmtblock_t block;
2023
2024   gfc_init_block (&block);
2025
2026   if (type == BT_CHARACTER)
2027     {
2028       gcc_assert (lse->string_length != NULL_TREE
2029               && rse->string_length != NULL_TREE);
2030
2031       gfc_conv_string_parameter (lse);
2032       gfc_conv_string_parameter (rse);
2033
2034       gfc_add_block_to_block (&block, &lse->pre);
2035       gfc_add_block_to_block (&block, &rse->pre);
2036
2037       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2038                              rse->string_length, rse->expr);
2039     }
2040   else
2041     {
2042       gfc_add_block_to_block (&block, &lse->pre);
2043       gfc_add_block_to_block (&block, &rse->pre);
2044
2045       gfc_add_modify_expr (&block, lse->expr,
2046                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
2047     }
2048
2049   gfc_add_block_to_block (&block, &lse->post);
2050   gfc_add_block_to_block (&block, &rse->post);
2051
2052   return gfc_finish_block (&block);
2053 }
2054
2055
2056 /* Try to translate array(:) = func (...), where func is a transformational
2057    array function, without using a temporary.  Returns NULL is this isn't the
2058    case.  */
2059
2060 static tree
2061 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2062 {
2063   gfc_se se;
2064   gfc_ss *ss;
2065
2066   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
2067   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2068     return NULL;
2069
2070   /* Elemental functions don't need a temporary anyway.  */
2071   if (expr2->symtree->n.sym->attr.elemental)
2072     return NULL;
2073
2074   /* Check for a dependency.  */
2075   if (gfc_check_fncall_dependency (expr1, expr2))
2076     return NULL;
2077
2078   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2079      functions.  */
2080   gcc_assert (expr2->value.function.isym
2081               || (gfc_return_by_reference (expr2->value.function.esym)
2082               && expr2->value.function.esym->result->attr.dimension));
2083
2084   ss = gfc_walk_expr (expr1);
2085   gcc_assert (ss != gfc_ss_terminator);
2086   gfc_init_se (&se, NULL);
2087   gfc_start_block (&se.pre);
2088   se.want_pointer = 1;
2089
2090   gfc_conv_array_parameter (&se, expr1, ss, 0);
2091
2092   se.direct_byref = 1;
2093   se.ss = gfc_walk_expr (expr2);
2094   gcc_assert (se.ss != gfc_ss_terminator);
2095   gfc_conv_function_expr (&se, expr2);
2096   gfc_add_block_to_block (&se.pre, &se.post);
2097
2098   return gfc_finish_block (&se.pre);
2099 }
2100
2101
2102 /* Translate an assignment.  Most of the code is concerned with
2103    setting up the scalarizer.  */
2104
2105 tree
2106 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2107 {
2108   gfc_se lse;
2109   gfc_se rse;
2110   gfc_ss *lss;
2111   gfc_ss *lss_section;
2112   gfc_ss *rss;
2113   gfc_loopinfo loop;
2114   tree tmp;
2115   stmtblock_t block;
2116   stmtblock_t body;
2117
2118   /* Special case a single function returning an array.  */
2119   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2120     {
2121       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2122       if (tmp)
2123         return tmp;
2124     }
2125
2126   /* Assignment of the form lhs = rhs.  */
2127   gfc_start_block (&block);
2128
2129   gfc_init_se (&lse, NULL);
2130   gfc_init_se (&rse, NULL);
2131
2132   /* Walk the lhs.  */
2133   lss = gfc_walk_expr (expr1);
2134   rss = NULL;
2135   if (lss != gfc_ss_terminator)
2136     {
2137       /* The assignment needs scalarization.  */
2138       lss_section = lss;
2139
2140       /* Find a non-scalar SS from the lhs.  */
2141       while (lss_section != gfc_ss_terminator
2142              && lss_section->type != GFC_SS_SECTION)
2143         lss_section = lss_section->next;
2144
2145       gcc_assert (lss_section != gfc_ss_terminator);
2146
2147       /* Initialize the scalarizer.  */
2148       gfc_init_loopinfo (&loop);
2149
2150       /* Walk the rhs.  */
2151       rss = gfc_walk_expr (expr2);
2152       if (rss == gfc_ss_terminator)
2153         {
2154           /* The rhs is scalar.  Add a ss for the expression.  */
2155           rss = gfc_get_ss ();
2156           rss->next = gfc_ss_terminator;
2157           rss->type = GFC_SS_SCALAR;
2158           rss->expr = expr2;
2159         }
2160       /* Associate the SS with the loop.  */
2161       gfc_add_ss_to_loop (&loop, lss);
2162       gfc_add_ss_to_loop (&loop, rss);
2163
2164       /* Calculate the bounds of the scalarization.  */
2165       gfc_conv_ss_startstride (&loop);
2166       /* Resolve any data dependencies in the statement.  */
2167       gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2168       /* Setup the scalarizing loops.  */
2169       gfc_conv_loop_setup (&loop);
2170
2171       /* Setup the gfc_se structures.  */
2172       gfc_copy_loopinfo_to_se (&lse, &loop);
2173       gfc_copy_loopinfo_to_se (&rse, &loop);
2174
2175       rse.ss = rss;
2176       gfc_mark_ss_chain_used (rss, 1);
2177       if (loop.temp_ss == NULL)
2178         {
2179           lse.ss = lss;
2180           gfc_mark_ss_chain_used (lss, 1);
2181         }
2182       else
2183         {
2184           lse.ss = loop.temp_ss;
2185           gfc_mark_ss_chain_used (lss, 3);
2186           gfc_mark_ss_chain_used (loop.temp_ss, 3);
2187         }
2188
2189       /* Start the scalarized loop body.  */
2190       gfc_start_scalarized_body (&loop, &body);
2191     }
2192   else
2193     gfc_init_block (&body);
2194
2195   /* Translate the expression.  */
2196   gfc_conv_expr (&rse, expr2);
2197
2198   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2199     {
2200       gfc_conv_tmp_array_ref (&lse);
2201       gfc_advance_se_ss_chain (&lse);
2202     }
2203   else
2204     gfc_conv_expr (&lse, expr1);
2205
2206   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2207   gfc_add_expr_to_block (&body, tmp);
2208
2209   if (lss == gfc_ss_terminator)
2210     {
2211       /* Use the scalar assignment as is.  */
2212       gfc_add_block_to_block (&block, &body);
2213     }
2214   else
2215     {
2216       gcc_assert (lse.ss == gfc_ss_terminator
2217                   && rse.ss == gfc_ss_terminator);
2218
2219       if (loop.temp_ss != NULL)
2220         {
2221           gfc_trans_scalarized_loop_boundary (&loop, &body);
2222
2223           /* We need to copy the temporary to the actual lhs.  */
2224           gfc_init_se (&lse, NULL);
2225           gfc_init_se (&rse, NULL);
2226           gfc_copy_loopinfo_to_se (&lse, &loop);
2227           gfc_copy_loopinfo_to_se (&rse, &loop);
2228
2229           rse.ss = loop.temp_ss;
2230           lse.ss = lss;
2231
2232           gfc_conv_tmp_array_ref (&rse);
2233           gfc_advance_se_ss_chain (&rse);
2234           gfc_conv_expr (&lse, expr1);
2235
2236           gcc_assert (lse.ss == gfc_ss_terminator
2237                       && rse.ss == gfc_ss_terminator);
2238
2239           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2240           gfc_add_expr_to_block (&body, tmp);
2241         }
2242       /* Generate the copying loops.  */
2243       gfc_trans_scalarizing_loops (&loop, &body);
2244
2245       /* Wrap the whole thing up.  */
2246       gfc_add_block_to_block (&block, &loop.pre);
2247       gfc_add_block_to_block (&block, &loop.post);
2248
2249       gfc_cleanup_loop (&loop);
2250     }
2251
2252   return gfc_finish_block (&block);
2253 }
2254
2255 tree
2256 gfc_trans_assign (gfc_code * code)
2257 {
2258   return gfc_trans_assignment (code->expr, code->expr2);
2259 }