OSDN Git Service

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