OSDN Git Service

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