OSDN Git Service

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