OSDN Git Service

1f98f9e1a89c6baaea1a0445afc95a237d0c338b
[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 GNU G95.
7
8 GNU G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU G95; see the file COPYING.  If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
21 Boston, MA 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-simple.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 SIMPLE 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
386 /* For power op (lhs ** rhs) We generate:
387     m = lhs
388     if (rhs > 0)
389       count = rhs
390     else if (rhs == 0)
391       {
392         count = 0
393         m = 1
394       }
395     else // (rhs < 0)
396       {
397         count = -rhs
398         m = 1 / m;
399       }
400     // for constant rhs we do the above at compile time
401     val = m;
402     for (n = 1; n < count; n++)
403       val = val * m;
404  */
405
406 static void
407 gfc_conv_integer_power (gfc_se * se, tree lhs, tree rhs)
408 {
409   tree count;
410   tree result;
411   tree cond;
412   tree neg_stmt;
413   tree pos_stmt;
414   tree tmp;
415   tree var;
416   tree type;
417   stmtblock_t block;
418   tree exit_label;
419
420   type = TREE_TYPE (lhs);
421
422   if (INTEGER_CST_P (rhs))
423     {
424       if (integer_zerop (rhs))
425         {
426           se->expr = gfc_build_const (type, integer_one_node);
427           return;
428         }
429       /* Special cases for constant values.  */
430       if (TREE_INT_CST_HIGH (rhs) == -1)
431         {
432           /* x ** (-y) == 1 / (x ** y).  */
433           if (TREE_CODE (type) == INTEGER_TYPE)
434             {
435               se->expr = integer_zero_node;
436               return;
437             }
438
439           tmp = gfc_build_const (type, integer_one_node);
440           lhs = fold (build (RDIV_EXPR, type, tmp, lhs));
441
442           rhs = fold (build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs));
443           assert (INTEGER_CST_P (rhs));
444         }
445       else
446         {
447           /* TODO: really big integer powers.  */
448           assert (TREE_INT_CST_HIGH (rhs) == 0);
449         }
450
451       if (integer_onep (rhs))
452         {
453           se->expr = lhs;
454           return;
455         }
456       if (TREE_INT_CST_LOW (rhs) == 2)
457         {
458           se->expr = build (MULT_EXPR, type, lhs, lhs);
459           return;
460         }
461       if (TREE_INT_CST_LOW (rhs) == 3)
462         {
463           tmp = build (MULT_EXPR, type, lhs, lhs);
464           se->expr = fold (build (MULT_EXPR, type, tmp, lhs));
465           return;
466         }
467
468       /* Create the loop count variable.  */
469       count = gfc_create_var (TREE_TYPE (rhs), "count");
470       gfc_add_modify_expr (&se->pre, count, rhs);
471     }
472   else
473     {
474       /* Put the lhs into a temporary variable.  */
475       var = gfc_create_var (type, "val");
476       count = gfc_create_var (TREE_TYPE (rhs), "count");
477       gfc_add_modify_expr (&se->pre, var, lhs);
478       lhs = var;
479
480       /* Generate code for negative rhs.  */
481       gfc_start_block (&block);
482
483       if (TREE_CODE (TREE_TYPE (lhs)) == INTEGER_TYPE)
484         {
485           gfc_add_modify_expr (&block, lhs, integer_zero_node);
486           gfc_add_modify_expr (&block, count, integer_zero_node);
487         }
488       else
489         {
490           tmp = gfc_build_const (type, integer_one_node);
491           tmp = build (RDIV_EXPR, type, tmp, lhs);
492           gfc_add_modify_expr (&block, var, tmp);
493
494           tmp = build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs);
495           gfc_add_modify_expr (&block, count, tmp);
496         }
497       neg_stmt = gfc_finish_block (&block);
498
499       pos_stmt = build_v (MODIFY_EXPR, count, rhs);
500
501       /* Code for rhs == 0.  */
502       gfc_start_block (&block);
503
504       gfc_add_modify_expr (&block, count, integer_zero_node);
505       tmp = gfc_build_const (type, integer_one_node);
506       gfc_add_modify_expr (&block, lhs, tmp);
507
508       tmp = gfc_finish_block (&block);
509
510       /* Select the appropriate action.  */
511       cond = build (EQ_EXPR, boolean_type_node, rhs, integer_zero_node);
512       tmp = build_v (COND_EXPR, cond, tmp, neg_stmt);
513
514       cond = build (GT_EXPR, boolean_type_node, rhs, integer_zero_node);
515       tmp = build_v (COND_EXPR, cond, pos_stmt, tmp);
516       gfc_add_expr_to_block (&se->pre, tmp);
517     }
518
519   /* Create a variable for the result.  */
520   result = gfc_create_var (type, "pow");
521   gfc_add_modify_expr (&se->pre, result, lhs);
522
523   exit_label = gfc_build_label_decl (NULL_TREE);
524   TREE_USED (exit_label) = 1;
525
526   /* Create the loop body.  */
527   gfc_start_block (&block);
528
529   /* First the exit condition (until count <= 1).  */
530   tmp = build1_v (GOTO_EXPR, exit_label);
531   cond = build (LE_EXPR, TREE_TYPE (count), count, integer_one_node);
532   tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
533   gfc_add_expr_to_block (&block, tmp);
534
535   /* Multiply by the lhs.  */
536   tmp = build (MULT_EXPR, type, result, lhs);
537   gfc_add_modify_expr (&block, result, tmp);
538
539   /* Adjust the loop count.  */
540   tmp = build (MINUS_EXPR, TREE_TYPE (count), count, integer_one_node);
541   gfc_add_modify_expr (&block, count, tmp);
542
543   tmp = gfc_finish_block (&block);
544
545   /* Create the the loop.  */
546   tmp = build_v (LOOP_EXPR, tmp);
547   gfc_add_expr_to_block (&se->pre, tmp);
548
549   /* Add the exit label.  */
550   tmp = build1_v (LABEL_EXPR, exit_label);
551   gfc_add_expr_to_block (&se->pre, tmp);
552
553   se->expr = result;
554 }
555
556
557 /* Power op (**).  Integer rhs has special handling.  */
558
559 static void
560 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
561 {
562   int kind;
563   gfc_se lse;
564   gfc_se rse;
565   tree fndecl;
566   tree tmp;
567   tree type;
568
569   gfc_init_se (&lse, se);
570   gfc_conv_expr_val (&lse, expr->op1);
571   gfc_add_block_to_block (&se->pre, &lse.pre);
572
573   gfc_init_se (&rse, se);
574   gfc_conv_expr_val (&rse, expr->op2);
575   gfc_add_block_to_block (&se->pre, &rse.pre);
576
577   type = TREE_TYPE (lse.expr);
578
579   kind = expr->op1->ts.kind;
580   switch (expr->op2->ts.type)
581     {
582     case BT_INTEGER:
583       /* Integer powers are expanded inline as multiplications.  */
584       gfc_conv_integer_power (se, lse.expr, rse.expr);
585       return;
586
587     case BT_REAL:
588       switch (kind)
589         {
590         case 4:
591           fndecl = gfor_fndecl_math_powf;
592           break;
593         case 8:
594           fndecl = gfor_fndecl_math_pow;
595           break;
596         default:
597           abort ();
598         }
599       break;
600
601     case BT_COMPLEX:
602       switch (kind)
603         {
604         case 4:
605           fndecl = gfor_fndecl_math_cpowf;
606           break;
607         case 8:
608           fndecl = gfor_fndecl_math_cpow;
609           break;
610         default:
611           abort ();
612         }
613       break;
614
615     default:
616       abort ();
617       break;
618     }
619
620   tmp = gfc_chainon_list (NULL_TREE, lse.expr);
621   tmp = gfc_chainon_list (tmp, rse.expr);
622   se->expr = gfc_build_function_call (fndecl, tmp);
623 }
624
625
626 /* Generate code to allocate a string temporary.  */
627
628 tree
629 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
630 {
631   tree var;
632   tree tmp;
633   tree args;
634
635   if (gfc_can_put_var_on_stack (len))
636     {
637       /* Create a temporary variable to hold the result.  */
638       tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
639       tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
640       tmp = build_array_type (gfc_character1_type_node, tmp);
641       var = gfc_create_var (tmp, "str");
642       var = gfc_build_addr_expr (type, var);
643     }
644   else
645     {
646       /* Allocate a temporary to hold the result.  */
647       var = gfc_create_var (type, "pstr");
648       args = gfc_chainon_list (NULL_TREE, len);
649       tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
650       tmp = convert (type, tmp);
651       gfc_add_modify_expr (&se->pre, var, tmp);
652
653       /* Free the temporary afterwards.  */
654       tmp = convert (pvoid_type_node, var);
655       args = gfc_chainon_list (NULL_TREE, tmp);
656       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
657       gfc_add_expr_to_block (&se->post, tmp);
658     }
659
660   return var;
661 }
662
663
664 /* Handle a string concatenation operation.  A temporary will be allocated to
665    hold the result.  */
666
667 static void
668 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
669 {
670   gfc_se lse;
671   gfc_se rse;
672   tree len;
673   tree type;
674   tree var;
675   tree args;
676   tree tmp;
677
678   assert (expr->op1->ts.type == BT_CHARACTER
679           && expr->op2->ts.type == BT_CHARACTER);
680
681   gfc_init_se (&lse, se);
682   gfc_conv_expr (&lse, expr->op1);
683   gfc_conv_string_parameter (&lse);
684   gfc_init_se (&rse, se);
685   gfc_conv_expr (&rse, expr->op2);
686   gfc_conv_string_parameter (&rse);
687
688   gfc_add_block_to_block (&se->pre, &lse.pre);
689   gfc_add_block_to_block (&se->pre, &rse.pre);
690
691   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
692   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
693   if (len == NULL_TREE)
694     {
695       len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
696                          lse.string_length, rse.string_length));
697     }
698
699   type = build_pointer_type (type);
700
701   var = gfc_conv_string_tmp (se, type, len);
702
703   /* Do the actual concatenation.  */
704   args = NULL_TREE;
705   args = gfc_chainon_list (args, len);
706   args = gfc_chainon_list (args, var);
707   args = gfc_chainon_list (args, lse.string_length);
708   args = gfc_chainon_list (args, lse.expr);
709   args = gfc_chainon_list (args, rse.string_length);
710   args = gfc_chainon_list (args, rse.expr);
711   tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
712   gfc_add_expr_to_block (&se->pre, tmp);
713
714   /* Add the cleanup for the operands.  */
715   gfc_add_block_to_block (&se->pre, &rse.post);
716   gfc_add_block_to_block (&se->pre, &lse.post);
717
718   se->expr = var;
719   se->string_length = len;
720 }
721
722
723 /* Translates an op expression. Common (binary) cases are handled by this
724    function, others are passed on. Recursion is used in either case.
725    We use the fact that (op1.ts == op2.ts) (except for the power
726    operand **).
727    Operators need no special handling for scalarized expressions as long as
728    they call gfc_conv_siple_val to get their operands.
729    Character strings get special handling.  */
730
731 static void
732 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
733 {
734   enum tree_code code;
735   gfc_se lse;
736   gfc_se rse;
737   tree type;
738   tree tmp;
739   int lop;
740   int checkstring;
741
742   checkstring = 0;
743   lop = 0;
744   switch (expr->operator)
745     {
746     case INTRINSIC_UPLUS:
747       gfc_conv_expr (se, expr->op1);
748       return;
749
750     case INTRINSIC_UMINUS:
751       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
752       return;
753
754     case INTRINSIC_NOT:
755       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
756       return;
757
758     case INTRINSIC_PLUS:
759       code = PLUS_EXPR;
760       break;
761
762     case INTRINSIC_MINUS:
763       code = MINUS_EXPR;
764       break;
765
766     case INTRINSIC_TIMES:
767       code = MULT_EXPR;
768       break;
769
770     case INTRINSIC_DIVIDE:
771       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
772          an integer, we must round towards zero, so we use a
773          TRUNC_DIV_EXPR.  */
774       if (expr->ts.type == BT_INTEGER)
775         code = TRUNC_DIV_EXPR;
776       else
777         code = RDIV_EXPR;
778       break;
779
780     case INTRINSIC_POWER:
781       gfc_conv_power_op (se, expr);
782       return;
783
784     case INTRINSIC_CONCAT:
785       gfc_conv_concat_op (se, expr);
786       return;
787
788     case INTRINSIC_AND:
789       code = TRUTH_ANDIF_EXPR;
790       lop = 1;
791       break;
792
793     case INTRINSIC_OR:
794       code = TRUTH_ORIF_EXPR;
795       lop = 1;
796       break;
797
798       /* EQV and NEQV only work on logicals, but since we represent them
799          as integers, we can use EQ_EXPR and NE_EXPR for them in SIMPLE.  */
800     case INTRINSIC_EQ:
801     case INTRINSIC_EQV:
802       code = EQ_EXPR;
803       checkstring = 1;
804       lop = 1;
805       break;
806
807     case INTRINSIC_NE:
808     case INTRINSIC_NEQV:
809       code = NE_EXPR;
810       checkstring = 1;
811       lop = 1;
812       break;
813
814     case INTRINSIC_GT:
815       code = GT_EXPR;
816       checkstring = 1;
817       lop = 1;
818       break;
819
820     case INTRINSIC_GE:
821       code = GE_EXPR;
822       checkstring = 1;
823       lop = 1;
824       break;
825
826     case INTRINSIC_LT:
827       code = LT_EXPR;
828       checkstring = 1;
829       lop = 1;
830       break;
831
832     case INTRINSIC_LE:
833       code = LE_EXPR;
834       checkstring = 1;
835       lop = 1;
836       break;
837
838     case INTRINSIC_USER:
839     case INTRINSIC_ASSIGN:
840       /* These should be converted into function calls by the frontend.  */
841       abort ();
842       return;
843
844     default:
845       fatal_error ("Unknown intrinsic op");
846       return;
847     }
848
849   /* The only exception to this is **, which is handled seperately anyway.  */
850   assert (expr->op1->ts.type == expr->op2->ts.type);
851
852   if (checkstring && expr->op1->ts.type != BT_CHARACTER)
853     checkstring = 0;
854
855   /* lhs */
856   gfc_init_se (&lse, se);
857   gfc_conv_expr (&lse, expr->op1);
858   gfc_add_block_to_block (&se->pre, &lse.pre);
859
860   /* rhs */
861   gfc_init_se (&rse, se);
862   gfc_conv_expr (&rse, expr->op2);
863   gfc_add_block_to_block (&se->pre, &rse.pre);
864
865   /* For string comparisons we generate a library call, and compare the return
866      value with 0.  */
867   if (checkstring)
868     {
869       gfc_conv_string_parameter (&lse);
870       gfc_conv_string_parameter (&rse);
871       tmp = NULL_TREE;
872       tmp = gfc_chainon_list (tmp, lse.string_length);
873       tmp = gfc_chainon_list (tmp, lse.expr);
874       tmp = gfc_chainon_list (tmp, rse.string_length);
875       tmp = gfc_chainon_list (tmp, rse.expr);
876
877       /* Build a call for the comparison.  */
878       lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
879       gfc_add_block_to_block (&lse.post, &rse.post);
880
881       rse.expr = integer_zero_node;
882     }
883
884   type = gfc_typenode_for_spec (&expr->ts);
885
886   if (lop)
887     {
888       /* The result of logical ops is always boolean_type_node.  */
889       tmp = fold (build (code, type, lse.expr, rse.expr));
890       se->expr = convert (type, tmp);
891     }
892   else
893     se->expr = fold (build (code, type, lse.expr, rse.expr));
894
895
896   /* Add the post blocks.  */
897   gfc_add_block_to_block (&se->post, &rse.post);
898   gfc_add_block_to_block (&se->post, &lse.post);
899 }
900
901 static void
902 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
903 {
904   tree tmp;
905
906   if (sym->attr.dummy)
907     {
908       tmp = gfc_get_symbol_decl (sym);
909       assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
910               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
911
912       se->expr = tmp;
913     }
914   else
915     {
916       if (!sym->backend_decl)
917         sym->backend_decl = gfc_get_extern_function_decl (sym);
918
919       tmp = sym->backend_decl;
920       assert (TREE_CODE (tmp) == FUNCTION_DECL);
921       se->expr = gfc_build_addr_expr (NULL, tmp);
922     }
923 }
924
925
926 /* Generate code for a procedure call.  Note can return se->post != NULL.
927    If se->direct_byref is set then se->expr contains the return parameter.  */
928
929 void
930 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
931                         gfc_actual_arglist * arg)
932 {
933   tree arglist;
934   tree tmp;
935   tree fntype;
936   gfc_se parmse;
937   gfc_ss *argss;
938   gfc_ss_info *info;
939   int byref;
940   tree type;
941   tree var;
942   tree len;
943   tree stringargs;
944   gfc_formal_arglist *formal;
945
946   arglist = NULL_TREE;
947   stringargs = NULL_TREE;
948   var = NULL_TREE;
949   len = NULL_TREE;
950
951   if (se->ss != NULL)
952     {
953       if (!sym->attr.elemental)
954         {
955           assert (se->ss->type == GFC_SS_FUNCTION);
956           if (se->ss->useflags)
957             {
958               assert (gfc_return_by_reference (sym)
959                       && sym->result->attr.dimension);
960               assert (se->loop != NULL);
961
962               /* Access the previously obtained result.  */
963               gfc_conv_tmp_array_ref (se);
964               gfc_advance_se_ss_chain (se);
965               return;
966             }
967         }
968       info = &se->ss->data.info;
969     }
970   else
971     info = NULL;
972
973   byref = gfc_return_by_reference (sym);
974   if (byref)
975     {
976       if (se->direct_byref)
977         arglist = gfc_chainon_list (arglist, se->expr);
978       else if (sym->result->attr.dimension)
979         {
980           assert (se->loop && se->ss);
981           /* Set the type of the array.  */
982           tmp = gfc_typenode_for_spec (&sym->ts);
983           info->dimen = se->loop->dimen;
984           /* Allocate a temporary to store the result.  */
985           gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
986
987           /* Zero the first stride to indicate a temporary.  */
988           tmp =
989             gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
990           gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
991           /* Pass the temporary as the first argument.  */
992           tmp = info->descriptor;
993           tmp = gfc_build_addr_expr (NULL, tmp);
994           arglist = gfc_chainon_list (arglist, tmp);
995         }
996       else if (sym->ts.type == BT_CHARACTER)
997         {
998           assert (sym->ts.cl && sym->ts.cl->length
999                   && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1000           len = gfc_conv_mpz_to_tree
1001             (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1002           sym->ts.cl->backend_decl = len;
1003           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1004           type = build_pointer_type (type);
1005
1006           var = gfc_conv_string_tmp (se, type, len);
1007           arglist = gfc_chainon_list (arglist, var);
1008           arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1009                                                         len));
1010         }
1011       else      /* TODO: derived type function return values.  */
1012         abort ();
1013     }
1014
1015   formal = sym->formal;
1016   /* Evaluate the arguments.  */
1017   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1018     {
1019       if (arg->expr == NULL)
1020         {
1021
1022           if (se->ignore_optional)
1023             {
1024               /* Some intrinsics have already been resolved to the correct
1025                  parameters.  */
1026               continue;
1027             }
1028           else if (arg->label)
1029             {
1030               has_alternate_specifier = 1;
1031               continue;
1032             }
1033           else
1034             {
1035               /* Pass a NULL pointer for an absent arg.  */
1036               gfc_init_se (&parmse, NULL);
1037               parmse.expr = null_pointer_node;
1038               if (formal && formal->sym->ts.type == BT_CHARACTER)
1039                 {
1040                   stringargs = gfc_chainon_list (stringargs,
1041                       convert (gfc_strlen_type_node, integer_zero_node));
1042                 }
1043             }
1044         }
1045       else if (se->ss && se->ss->useflags)
1046         {
1047           /* An elemental function inside a scalarized loop.  */
1048           gfc_init_se (&parmse, se);
1049           gfc_conv_expr_reference (&parmse, arg->expr);
1050         }
1051       else
1052         {
1053           /* A scalar or transformational function.  */
1054           gfc_init_se (&parmse, NULL);
1055           argss = gfc_walk_expr (arg->expr);
1056
1057           if (argss == gfc_ss_terminator)
1058             {
1059               gfc_conv_expr_reference (&parmse, arg->expr);
1060               if (formal && formal->sym->attr.pointer)
1061                 {
1062                   /* Scalar pointer dummy args require an extra level of
1063                      indirection.  */
1064                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1065                 }
1066             }
1067           else
1068             {
1069               /* If the procedure requires explicit interface, actual argument
1070                  is passed according to corresponing formal argument.  We
1071                  do not use g77 method and the address of array descriptor
1072                  is passed if corresponing formal is pointer or
1073                  assumed-shape,  Otherwise use g77 method.  */
1074               int f;
1075               f = (formal != NULL)
1076                   && !formal->sym->attr.pointer
1077                   && formal->sym->as->type != AS_ASSUMED_SHAPE;
1078               f = f || !sym->attr.always_explicit;
1079               gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1080             } 
1081         }
1082
1083       gfc_add_block_to_block (&se->pre, &parmse.pre);
1084       gfc_add_block_to_block (&se->post, &parmse.post);
1085
1086       /* Character strings are passed as two paramarers, a length and a
1087          pointer.  */
1088       if (parmse.string_length != NULL_TREE)
1089         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1090
1091       arglist = gfc_chainon_list (arglist, parmse.expr);
1092     }
1093
1094   /* Add the hidden string length parameters to the arguments.  */
1095   arglist = chainon (arglist, stringargs);
1096
1097   /* Generate the actual call.  */
1098   gfc_conv_function_val (se, sym);
1099   /* If there are alternate return labels, function type should be
1100      integer.  */
1101   if (has_alternate_specifier)
1102     TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1103
1104   fntype = TREE_TYPE (TREE_TYPE (se->expr));
1105   se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1106                     arglist, NULL_TREE);
1107
1108 /* A pure function may still have side-effects - it may modify its
1109    parameters.  */
1110   TREE_SIDE_EFFECTS (se->expr) = 1;
1111 #if 0
1112   if (!sym->attr.pure)
1113     TREE_SIDE_EFFECTS (se->expr) = 1;
1114 #endif
1115
1116   if (byref && !se->direct_byref)
1117     {
1118       gfc_add_expr_to_block (&se->pre, se->expr);
1119
1120       if (sym->result->attr.dimension)
1121         {
1122           if (flag_bounds_check)
1123             {
1124               /* Check the data pointer hasn't been modified.  This would happen
1125                  in a function returning a pointer.  */
1126               tmp = gfc_conv_descriptor_data (info->descriptor);
1127               tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
1128               gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1129             }
1130           se->expr = info->descriptor;
1131         }
1132       else if (sym->ts.type == BT_CHARACTER)
1133         {
1134           se->expr = var;
1135           se->string_length = len;
1136         }
1137       else
1138         abort ();
1139     }
1140 }
1141
1142
1143 /* Translate a statement function.
1144    The value of a statement function reference is obtained by evaluating the
1145    expression using the values of the actual arguments for the values of the
1146    corresponding dummy arguments.  */
1147
1148 static void
1149 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1150 {
1151   gfc_symbol *sym;
1152   gfc_symbol *fsym;
1153   gfc_formal_arglist *fargs;
1154   gfc_actual_arglist *args;
1155   gfc_se lse;
1156   gfc_se rse;
1157
1158   sym = expr->symtree->n.sym;
1159   args = expr->value.function.actual;
1160   gfc_init_se (&lse, NULL);
1161   gfc_init_se (&rse, NULL);
1162
1163   for (fargs = sym->formal; fargs; fargs = fargs->next)
1164     {
1165       /* Each dummy shall be specified, explicitly or implicitly, to be
1166          scalar.  */
1167       assert (fargs->sym->attr.dimension == 0);
1168       fsym = fargs->sym;
1169       assert (fsym->backend_decl);
1170
1171       /* Convert non-pointer string dummy.  */
1172       if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer)
1173         {
1174           tree len1;
1175           tree len2;
1176           tree arg;
1177           tree tmp;
1178           tree type;
1179           tree var;
1180
1181           assert (fsym->ts.cl && fsym->ts.cl->length
1182                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1183
1184           type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl);
1185           len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1186           var = gfc_build_addr_expr (build_pointer_type (type),
1187                                      fsym->backend_decl);
1188
1189           gfc_conv_expr (&rse, args->expr);
1190           gfc_conv_string_parameter (&rse);
1191           len2 = rse.string_length;
1192           gfc_add_block_to_block (&se->pre, &lse.pre);
1193           gfc_add_block_to_block (&se->pre, &rse.pre);
1194
1195           arg = NULL_TREE;
1196           arg = gfc_chainon_list (arg, len1);
1197           arg = gfc_chainon_list (arg, var);
1198           arg = gfc_chainon_list (arg, len2);
1199           arg = gfc_chainon_list (arg, rse.expr);
1200           tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg);
1201           gfc_add_expr_to_block (&se->pre, tmp);
1202           gfc_add_block_to_block (&se->pre, &lse.post);
1203           gfc_add_block_to_block (&se->pre, &rse.post);
1204         }
1205       else
1206         {
1207           /* For everything else, just evaluate the expression.  */
1208           if (fsym->attr.pointer == 1)
1209             lse.want_pointer = 1;
1210
1211           gfc_conv_expr (&lse, args->expr);
1212
1213           gfc_add_block_to_block (&se->pre, &lse.pre);
1214           gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr);
1215           gfc_add_block_to_block (&se->pre, &lse.post);
1216         }
1217       args = args->next;
1218     }
1219   gfc_conv_expr (se, sym->value);
1220 }
1221
1222
1223 /* Translate a function expression.  */
1224
1225 static void
1226 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1227 {
1228   gfc_symbol *sym;
1229
1230   if (expr->value.function.isym)
1231     {
1232       gfc_conv_intrinsic_function (se, expr);
1233       return;
1234     }
1235
1236   /* We distinguish the statement function from general function to improve
1237      runtime performance.  */
1238   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1239     {
1240       gfc_conv_statement_function (se, expr);
1241       return;
1242     }
1243
1244   /* expr.value.function.esym is the resolved (specific) function symbol for
1245      most functions.  However this isn't set for dummy procedures.  */
1246   sym = expr->value.function.esym;
1247   if (!sym)
1248     sym = expr->symtree->n.sym;
1249   gfc_conv_function_call (se, sym, expr->value.function.actual);
1250 }
1251
1252 static void
1253 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1254 {
1255   assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1256   assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1257
1258   gfc_conv_tmp_array_ref (se);
1259   gfc_advance_se_ss_chain (se);
1260 }
1261
1262
1263
1264 /* Build an expression for a constructor. If init is nonzero then
1265    this is part of a static variable initializer.  */
1266
1267 void
1268 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1269 {
1270   gfc_constructor *c;
1271   gfc_component *cm;
1272   tree head;
1273   tree tail;
1274   tree val;
1275   gfc_se cse;
1276   tree type;
1277   tree arraytype;
1278
1279   assert (expr->expr_type == EXPR_STRUCTURE);
1280   type = gfc_typenode_for_spec (&expr->ts);
1281   head = build1 (CONSTRUCTOR, type, NULL_TREE);
1282   tail = NULL_TREE;
1283
1284   cm = expr->ts.derived->components;
1285   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1286     {
1287       /* Skip absent members in default initializers.  */
1288       if (!c->expr)
1289         continue;
1290
1291       gfc_init_se (&cse, se);
1292       /* Evaluate the expression for this component.  */
1293       if (init)
1294         {
1295           if (cm->dimension)
1296             {
1297               arraytype = TREE_TYPE (cm->backend_decl);
1298               cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
1299             }
1300           else if (cm->ts.type == BT_DERIVED)
1301             gfc_conv_structure (&cse, c->expr, 1);
1302           else
1303             gfc_conv_expr (&cse, c->expr);
1304         }
1305       else
1306         {
1307           gfc_conv_expr (&cse, c->expr);
1308           gfc_add_block_to_block (&se->pre, &cse.pre);
1309           gfc_add_block_to_block (&se->post, &cse.post);
1310         }
1311
1312       /* Build a TREE_CHAIN to hold it.  */
1313       val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
1314
1315       /* Add it to the list.  */
1316       if (tail == NULL_TREE)
1317         TREE_OPERAND(head, 0) = tail = val;
1318       else
1319         {
1320           TREE_CHAIN (tail) = val;
1321           tail = val;
1322         }
1323     }
1324   se->expr = head;
1325 }
1326
1327
1328 /*translate a substring expression */
1329
1330 static void
1331 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1332 {
1333   gfc_ref *ref;
1334
1335   ref = expr->ref;
1336
1337   assert(ref->type == REF_SUBSTRING);
1338
1339   se->expr = gfc_build_string_const(expr->value.character.length,
1340                                     expr->value.character.string);
1341   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1342   TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1343
1344   gfc_conv_substring(se,ref,expr->ts.kind);
1345 }
1346
1347
1348 /* Entry point for expression translation.  */
1349
1350 void
1351 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1352 {
1353   if (se->ss && se->ss->expr == expr
1354       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1355     {
1356       /* Substiture a scalar expression evaluated outside the scalarization
1357          loop.  */
1358       se->expr = se->ss->data.scalar.expr;
1359       se->string_length = se->ss->data.scalar.string_length;
1360       gfc_advance_se_ss_chain (se);
1361       return;
1362     }
1363
1364   switch (expr->expr_type)
1365     {
1366     case EXPR_OP:
1367       gfc_conv_expr_op (se, expr);
1368       break;
1369
1370     case EXPR_FUNCTION:
1371       gfc_conv_function_expr (se, expr);
1372       break;
1373
1374     case EXPR_CONSTANT:
1375       gfc_conv_constant (se, expr);
1376       break;
1377
1378     case EXPR_VARIABLE:
1379       gfc_conv_variable (se, expr);
1380       break;
1381
1382     case EXPR_NULL:
1383       se->expr = null_pointer_node;
1384       break;
1385
1386     case EXPR_SUBSTRING:
1387       gfc_conv_substring_expr (se, expr);
1388       break;
1389
1390     case EXPR_STRUCTURE:
1391       gfc_conv_structure (se, expr, 0);
1392       break;
1393
1394     case EXPR_ARRAY:
1395       gfc_conv_array_constructor_expr (se, expr);
1396       break;
1397
1398     default:
1399       abort ();
1400       break;
1401     }
1402 }
1403
1404 void
1405 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1406 {
1407   gfc_conv_expr (se, expr);
1408   /* AFAICS all numeric lvalues have empty post chains.  If not we need to
1409      figure out a way of rewriting an lvalue so that it has no post chain.  */
1410   assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1411 }
1412
1413 void
1414 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1415 {
1416   tree val;
1417
1418   assert (expr->ts.type != BT_CHARACTER);
1419   gfc_conv_expr (se, expr);
1420   if (se->post.head)
1421     {
1422       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1423       gfc_add_modify_expr (&se->pre, val, se->expr);
1424     }
1425 }
1426
1427 void
1428 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1429 {
1430   gfc_conv_expr_val (se, expr);
1431   se->expr = convert (type, se->expr);
1432 }
1433
1434
1435 /* Converts an expression so that it can be passed by refernece.  Scalar
1436    values only.  */
1437
1438 void
1439 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1440 {
1441   tree var;
1442
1443   if (se->ss && se->ss->expr == expr
1444       && se->ss->type == GFC_SS_REFERENCE)
1445     {
1446       se->expr = se->ss->data.scalar.expr;
1447       se->string_length = se->ss->data.scalar.string_length;
1448       gfc_advance_se_ss_chain (se);
1449       return;
1450     }
1451
1452   if (expr->ts.type == BT_CHARACTER)
1453     {
1454       gfc_conv_expr (se, expr);
1455       gfc_conv_string_parameter (se);
1456       return;
1457     }
1458
1459   if (expr->expr_type == EXPR_VARIABLE)
1460     {
1461       se->want_pointer = 1;
1462       gfc_conv_expr (se, expr);
1463       if (se->post.head)
1464         {
1465           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1466           gfc_add_modify_expr (&se->pre, var, se->expr);
1467           gfc_add_block_to_block (&se->pre, &se->post);
1468           se->expr = var;
1469         }
1470       return;
1471     }
1472
1473   gfc_conv_expr (se, expr);
1474
1475   /* Create a temporary var to hold the value.  */
1476   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1477   gfc_add_modify_expr (&se->pre, var, se->expr);
1478   gfc_add_block_to_block (&se->pre, &se->post);
1479
1480   /* Take the address of that value.  */
1481   se->expr = gfc_build_addr_expr (NULL, var);
1482 }
1483
1484
1485 tree
1486 gfc_trans_pointer_assign (gfc_code * code)
1487 {
1488   return gfc_trans_pointer_assignment (code->expr, code->expr2);
1489 }
1490
1491
1492 tree
1493 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1494 {
1495   gfc_se lse;
1496   gfc_se rse;
1497   gfc_ss *lss;
1498   gfc_ss *rss;
1499   stmtblock_t block;
1500   tree tmp;
1501
1502   gfc_start_block (&block);
1503
1504   gfc_init_se (&lse, NULL);
1505
1506   lss = gfc_walk_expr (expr1);
1507   rss = gfc_walk_expr (expr2);
1508   if (lss == gfc_ss_terminator)
1509     {
1510       lse.want_pointer = 1;
1511       gfc_conv_expr (&lse, expr1);
1512       assert (rss == gfc_ss_terminator);
1513       gfc_init_se (&rse, NULL);
1514       rse.want_pointer = 1;
1515       gfc_conv_expr (&rse, expr2);
1516       gfc_add_block_to_block (&block, &lse.pre);
1517       gfc_add_block_to_block (&block, &rse.pre);
1518       gfc_add_modify_expr (&block, lse.expr, rse.expr);
1519       gfc_add_block_to_block (&block, &rse.post);
1520       gfc_add_block_to_block (&block, &lse.post);
1521     }
1522   else
1523     {
1524       gfc_conv_expr_descriptor (&lse, expr1, lss);
1525       /* Implement Nullify.  */
1526       if (expr2->expr_type == EXPR_NULL)
1527         {
1528           lse.expr = gfc_conv_descriptor_data (lse.expr);
1529           rse.expr = null_pointer_node;
1530           tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
1531           gfc_add_expr_to_block (&block, tmp);
1532         }
1533       else
1534         {
1535           lse.direct_byref = 1;
1536           gfc_conv_expr_descriptor (&lse, expr2, rss);
1537         }
1538       gfc_add_block_to_block (&block, &lse.pre);
1539       gfc_add_block_to_block (&block, &lse.post);
1540     }
1541   return gfc_finish_block (&block);
1542 }
1543
1544
1545 /* Makes sure se is suitable for passing as a function string parameter.  */
1546 /* TODO: Need to check all callers fo this function.  It may be abused.  */
1547
1548 void
1549 gfc_conv_string_parameter (gfc_se * se)
1550 {
1551   tree type;
1552
1553   if (TREE_CODE (se->expr) == STRING_CST)
1554     {
1555       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1556       return;
1557     }
1558
1559   type = TREE_TYPE (se->expr);
1560   if (TYPE_STRING_FLAG (type))
1561     {
1562       assert (TREE_CODE (se->expr) != INDIRECT_REF);
1563       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1564     }
1565
1566   assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1567   assert (se->string_length
1568           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1569 }
1570
1571
1572 /* Generate code for assignment of scalar variables.  Includes character
1573    strings.  */
1574
1575 tree
1576 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1577 {
1578   tree tmp;
1579   tree args;
1580   stmtblock_t block;
1581
1582   gfc_init_block (&block);
1583
1584
1585   if (type == BT_CHARACTER)
1586     {
1587       args = NULL_TREE;
1588
1589       assert (lse->string_length != NULL_TREE
1590               && rse->string_length != NULL_TREE);
1591
1592       gfc_conv_string_parameter (lse);
1593       gfc_conv_string_parameter (rse);
1594
1595       gfc_add_block_to_block (&block, &lse->pre);
1596       gfc_add_block_to_block (&block, &rse->pre);
1597
1598       args = gfc_chainon_list (args, lse->string_length);
1599       args = gfc_chainon_list (args, lse->expr);
1600       args = gfc_chainon_list (args, rse->string_length);
1601       args = gfc_chainon_list (args, rse->expr);
1602
1603       tmp = gfc_build_function_call (gfor_fndecl_copy_string, args);
1604       gfc_add_expr_to_block (&block, tmp);
1605     }
1606   else
1607     {
1608       gfc_add_block_to_block (&block, &lse->pre);
1609       gfc_add_block_to_block (&block, &rse->pre);
1610
1611       gfc_add_modify_expr (&block, lse->expr, rse->expr);
1612     }
1613
1614   gfc_add_block_to_block (&block, &lse->post);
1615   gfc_add_block_to_block (&block, &rse->post);
1616
1617   return gfc_finish_block (&block);
1618 }
1619
1620
1621 /* Try to translate array(:) = func (...), where func is a transformational
1622    array function, without using a temporary.  Returns NULL is this isn't the
1623    case.  */
1624
1625 static tree
1626 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1627 {
1628   gfc_se se;
1629   gfc_ss *ss;
1630
1631   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
1632   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1633     return NULL;
1634
1635   /* Elemental functions don't need a temporary anyway.  */
1636   if (expr2->symtree->n.sym->attr.elemental)
1637     return NULL;
1638
1639   /* Check for a dependency.  */
1640   if (gfc_check_fncall_dependency (expr1, expr2))
1641     return NULL;
1642
1643   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1644      functions.  */
1645   assert (expr2->value.function.isym
1646           || (gfc_return_by_reference (expr2->symtree->n.sym)
1647               && expr2->symtree->n.sym->result->attr.dimension));
1648
1649   ss = gfc_walk_expr (expr1);
1650   assert (ss != gfc_ss_terminator);
1651   gfc_init_se (&se, NULL);
1652   gfc_start_block (&se.pre);
1653   se.want_pointer = 1;
1654
1655   gfc_conv_array_parameter (&se, expr1, ss, 0);
1656
1657   se.direct_byref = 1;
1658   se.ss = gfc_walk_expr (expr2);
1659   assert (se.ss != gfc_ss_terminator);
1660   gfc_conv_function_expr (&se, expr2);
1661   gfc_add_expr_to_block (&se.pre, se.expr);
1662   gfc_add_block_to_block (&se.pre, &se.post);
1663
1664   return gfc_finish_block (&se.pre);
1665 }
1666
1667
1668 /* Translate an assignment.  Most of the code is concerned with
1669    setting up the scalarizer.  */
1670
1671 tree
1672 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
1673 {
1674   gfc_se lse;
1675   gfc_se rse;
1676   gfc_ss *lss;
1677   gfc_ss *lss_section;
1678   gfc_ss *rss;
1679   gfc_loopinfo loop;
1680   tree tmp;
1681   stmtblock_t block;
1682   stmtblock_t body;
1683
1684   /* Special case a single function returning an array.  */
1685   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
1686     {
1687       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
1688       if (tmp)
1689         return tmp;
1690     }
1691
1692   /* Assignment of the form lhs = rhs.  */
1693   gfc_start_block (&block);
1694
1695   gfc_init_se (&lse, NULL);
1696   gfc_init_se (&rse, NULL);
1697
1698   /* Walk the lhs.  */
1699   lss = gfc_walk_expr (expr1);
1700   rss = NULL;
1701   if (lss != gfc_ss_terminator)
1702     {
1703       /* The assignment needs scalarization.  */
1704       lss_section = lss;
1705
1706       /* Find a non-scalar SS from the lhs.  */
1707       while (lss_section != gfc_ss_terminator
1708              && lss_section->type != GFC_SS_SECTION)
1709         lss_section = lss_section->next;
1710
1711       assert (lss_section != gfc_ss_terminator);
1712
1713       /* Initialize the scalarizer.  */
1714       gfc_init_loopinfo (&loop);
1715
1716       /* Walk the rhs.  */
1717       rss = gfc_walk_expr (expr2);
1718       if (rss == gfc_ss_terminator)
1719         {
1720           /* The rhs is scalar.  Add a ss for the expression.  */
1721           rss = gfc_get_ss ();
1722           rss->next = gfc_ss_terminator;
1723           rss->type = GFC_SS_SCALAR;
1724           rss->expr = expr2;
1725         }
1726       /* Associate the SS with the loop.  */
1727       gfc_add_ss_to_loop (&loop, lss);
1728       gfc_add_ss_to_loop (&loop, rss);
1729
1730       /* Calculate the bounds of the scalarization.  */
1731       gfc_conv_ss_startstride (&loop);
1732       /* Resolve any data dependencies in the statement.  */
1733       gfc_conv_resolve_dependencies (&loop, lss_section, rss);
1734       /* Setup the scalarizing loops.  */
1735       gfc_conv_loop_setup (&loop);
1736
1737       /* Setup the gfc_se structures.  */
1738       gfc_copy_loopinfo_to_se (&lse, &loop);
1739       gfc_copy_loopinfo_to_se (&rse, &loop);
1740
1741       rse.ss = rss;
1742       gfc_mark_ss_chain_used (rss, 1);
1743       if (loop.temp_ss == NULL)
1744         {
1745           lse.ss = lss;
1746           gfc_mark_ss_chain_used (lss, 1);
1747         }
1748       else
1749         {
1750           lse.ss = loop.temp_ss;
1751           gfc_mark_ss_chain_used (lss, 3);
1752           gfc_mark_ss_chain_used (loop.temp_ss, 3);
1753         }
1754
1755       /* Start the scalarized loop body.  */
1756       gfc_start_scalarized_body (&loop, &body);
1757     }
1758   else
1759     gfc_init_block (&body);
1760
1761   /* Translate the expression.  */
1762   gfc_conv_expr (&rse, expr2);
1763
1764   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
1765     {
1766       gfc_conv_tmp_array_ref (&lse);
1767       gfc_advance_se_ss_chain (&lse);
1768     }
1769   else
1770     gfc_conv_expr (&lse, expr1);
1771
1772   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1773   gfc_add_expr_to_block (&body, tmp);
1774
1775   if (lss == gfc_ss_terminator)
1776     {
1777       /* Use the scalar assignment as is.  */
1778       gfc_add_block_to_block (&block, &body);
1779     }
1780   else
1781     {
1782       if (lse.ss != gfc_ss_terminator)
1783         abort ();
1784       if (rse.ss != gfc_ss_terminator)
1785         abort ();
1786
1787       if (loop.temp_ss != NULL)
1788         {
1789           gfc_trans_scalarized_loop_boundary (&loop, &body);
1790
1791           /* We need to copy the temporary to the actual lhs.  */
1792           gfc_init_se (&lse, NULL);
1793           gfc_init_se (&rse, NULL);
1794           gfc_copy_loopinfo_to_se (&lse, &loop);
1795           gfc_copy_loopinfo_to_se (&rse, &loop);
1796
1797           rse.ss = loop.temp_ss;
1798           lse.ss = lss;
1799
1800           gfc_conv_tmp_array_ref (&rse);
1801           gfc_advance_se_ss_chain (&rse);
1802           gfc_conv_expr (&lse, expr1);
1803
1804           if (lse.ss != gfc_ss_terminator)
1805             abort ();
1806
1807           if (rse.ss != gfc_ss_terminator)
1808             abort ();
1809
1810           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1811           gfc_add_expr_to_block (&body, tmp);
1812         }
1813       /* Generate the copying loops.  */
1814       gfc_trans_scalarizing_loops (&loop, &body);
1815
1816       /* Wrap the whole thing up.  */
1817       gfc_add_block_to_block (&block, &loop.pre);
1818       gfc_add_block_to_block (&block, &loop.post);
1819
1820       gfc_cleanup_loop (&loop);
1821     }
1822
1823   return gfc_finish_block (&block);
1824 }
1825
1826 tree
1827 gfc_trans_assign (gfc_code * code)
1828 {
1829   return gfc_trans_assignment (code->expr, code->expr2);
1830 }