OSDN Git Service

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