OSDN Git Service

2007-07-19 Christopher D. Rickett <crickett@lanl.gov>
[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           /* Use builtins for real ** int4.  */
856           if (ikind == 0)
857             {
858               switch (kind)
859                 {
860                 case 0:
861                   fndecl = built_in_decls[BUILT_IN_POWIF];
862                   break;
863                 
864                 case 1:
865                   fndecl = built_in_decls[BUILT_IN_POWI];
866                   break;
867
868                 case 2:
869                 case 3:
870                   fndecl = built_in_decls[BUILT_IN_POWIL];
871                   break;
872
873                 default:
874                   gcc_unreachable ();
875                 }
876             }
877           else
878             fndecl = gfor_fndecl_math_powi[kind][ikind].real;
879           break;
880
881         case BT_COMPLEX:
882           fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
883           break;
884
885         default:
886           gcc_unreachable ();
887         }
888       break;
889
890     case BT_REAL:
891       switch (kind)
892         {
893         case 4:
894           fndecl = built_in_decls[BUILT_IN_POWF];
895           break;
896         case 8:
897           fndecl = built_in_decls[BUILT_IN_POW];
898           break;
899         case 10:
900         case 16:
901           fndecl = built_in_decls[BUILT_IN_POWL];
902           break;
903         default:
904           gcc_unreachable ();
905         }
906       break;
907
908     case BT_COMPLEX:
909       switch (kind)
910         {
911         case 4:
912           fndecl = gfor_fndecl_math_cpowf;
913           break;
914         case 8:
915           fndecl = gfor_fndecl_math_cpow;
916           break;
917         case 10:
918           fndecl = gfor_fndecl_math_cpowl10;
919           break;
920         case 16:
921           fndecl = gfor_fndecl_math_cpowl16;
922           break;
923         default:
924           gcc_unreachable ();
925         }
926       break;
927
928     default:
929       gcc_unreachable ();
930       break;
931     }
932
933   se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
934 }
935
936
937 /* Generate code to allocate a string temporary.  */
938
939 tree
940 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
941 {
942   tree var;
943   tree tmp;
944
945   gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
946
947   if (gfc_can_put_var_on_stack (len))
948     {
949       /* Create a temporary variable to hold the result.  */
950       tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
951                          build_int_cst (gfc_charlen_type_node, 1));
952       tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
953       tmp = build_array_type (gfc_character1_type_node, tmp);
954       var = gfc_create_var (tmp, "str");
955       var = gfc_build_addr_expr (type, var);
956     }
957   else
958     {
959       /* Allocate a temporary to hold the result.  */
960       var = gfc_create_var (type, "pstr");
961       tmp = gfc_call_malloc (&se->pre, type, len);
962       gfc_add_modify_expr (&se->pre, var, tmp);
963
964       /* Free the temporary afterwards.  */
965       tmp = gfc_call_free (convert (pvoid_type_node, var));
966       gfc_add_expr_to_block (&se->post, tmp);
967     }
968
969   return var;
970 }
971
972
973 /* Handle a string concatenation operation.  A temporary will be allocated to
974    hold the result.  */
975
976 static void
977 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
978 {
979   gfc_se lse;
980   gfc_se rse;
981   tree len;
982   tree type;
983   tree var;
984   tree tmp;
985
986   gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
987           && expr->value.op.op2->ts.type == BT_CHARACTER);
988
989   gfc_init_se (&lse, se);
990   gfc_conv_expr (&lse, expr->value.op.op1);
991   gfc_conv_string_parameter (&lse);
992   gfc_init_se (&rse, se);
993   gfc_conv_expr (&rse, expr->value.op.op2);
994   gfc_conv_string_parameter (&rse);
995
996   gfc_add_block_to_block (&se->pre, &lse.pre);
997   gfc_add_block_to_block (&se->pre, &rse.pre);
998
999   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1000   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1001   if (len == NULL_TREE)
1002     {
1003       len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1004                          lse.string_length, rse.string_length);
1005     }
1006
1007   type = build_pointer_type (type);
1008
1009   var = gfc_conv_string_tmp (se, type, len);
1010
1011   /* Do the actual concatenation.  */
1012   tmp = build_call_expr (gfor_fndecl_concat_string, 6,
1013                          len, var,
1014                          lse.string_length, lse.expr,
1015                          rse.string_length, rse.expr);
1016   gfc_add_expr_to_block (&se->pre, tmp);
1017
1018   /* Add the cleanup for the operands.  */
1019   gfc_add_block_to_block (&se->pre, &rse.post);
1020   gfc_add_block_to_block (&se->pre, &lse.post);
1021
1022   se->expr = var;
1023   se->string_length = len;
1024 }
1025
1026 /* Translates an op expression. Common (binary) cases are handled by this
1027    function, others are passed on. Recursion is used in either case.
1028    We use the fact that (op1.ts == op2.ts) (except for the power
1029    operator **).
1030    Operators need no special handling for scalarized expressions as long as
1031    they call gfc_conv_simple_val to get their operands.
1032    Character strings get special handling.  */
1033
1034 static void
1035 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1036 {
1037   enum tree_code code;
1038   gfc_se lse;
1039   gfc_se rse;
1040   tree type;
1041   tree tmp;
1042   int lop;
1043   int checkstring;
1044
1045   checkstring = 0;
1046   lop = 0;
1047   switch (expr->value.op.operator)
1048     {
1049     case INTRINSIC_UPLUS:
1050     case INTRINSIC_PARENTHESES:
1051       gfc_conv_expr (se, expr->value.op.op1);
1052       return;
1053
1054     case INTRINSIC_UMINUS:
1055       gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1056       return;
1057
1058     case INTRINSIC_NOT:
1059       gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1060       return;
1061
1062     case INTRINSIC_PLUS:
1063       code = PLUS_EXPR;
1064       break;
1065
1066     case INTRINSIC_MINUS:
1067       code = MINUS_EXPR;
1068       break;
1069
1070     case INTRINSIC_TIMES:
1071       code = MULT_EXPR;
1072       break;
1073
1074     case INTRINSIC_DIVIDE:
1075       /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1076          an integer, we must round towards zero, so we use a
1077          TRUNC_DIV_EXPR.  */
1078       if (expr->ts.type == BT_INTEGER)
1079         code = TRUNC_DIV_EXPR;
1080       else
1081         code = RDIV_EXPR;
1082       break;
1083
1084     case INTRINSIC_POWER:
1085       gfc_conv_power_op (se, expr);
1086       return;
1087
1088     case INTRINSIC_CONCAT:
1089       gfc_conv_concat_op (se, expr);
1090       return;
1091
1092     case INTRINSIC_AND:
1093       code = TRUTH_ANDIF_EXPR;
1094       lop = 1;
1095       break;
1096
1097     case INTRINSIC_OR:
1098       code = TRUTH_ORIF_EXPR;
1099       lop = 1;
1100       break;
1101
1102       /* EQV and NEQV only work on logicals, but since we represent them
1103          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
1104     case INTRINSIC_EQ:
1105     case INTRINSIC_EQ_OS:
1106     case INTRINSIC_EQV:
1107       code = EQ_EXPR;
1108       checkstring = 1;
1109       lop = 1;
1110       break;
1111
1112     case INTRINSIC_NE:
1113     case INTRINSIC_NE_OS:
1114     case INTRINSIC_NEQV:
1115       code = NE_EXPR;
1116       checkstring = 1;
1117       lop = 1;
1118       break;
1119
1120     case INTRINSIC_GT:
1121     case INTRINSIC_GT_OS:
1122       code = GT_EXPR;
1123       checkstring = 1;
1124       lop = 1;
1125       break;
1126
1127     case INTRINSIC_GE:
1128     case INTRINSIC_GE_OS:
1129       code = GE_EXPR;
1130       checkstring = 1;
1131       lop = 1;
1132       break;
1133
1134     case INTRINSIC_LT:
1135     case INTRINSIC_LT_OS:
1136       code = LT_EXPR;
1137       checkstring = 1;
1138       lop = 1;
1139       break;
1140
1141     case INTRINSIC_LE:
1142     case INTRINSIC_LE_OS:
1143       code = LE_EXPR;
1144       checkstring = 1;
1145       lop = 1;
1146       break;
1147
1148     case INTRINSIC_USER:
1149     case INTRINSIC_ASSIGN:
1150       /* These should be converted into function calls by the frontend.  */
1151       gcc_unreachable ();
1152
1153     default:
1154       fatal_error ("Unknown intrinsic op");
1155       return;
1156     }
1157
1158   /* The only exception to this is **, which is handled separately anyway.  */
1159   gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1160
1161   if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1162     checkstring = 0;
1163
1164   /* lhs */
1165   gfc_init_se (&lse, se);
1166   gfc_conv_expr (&lse, expr->value.op.op1);
1167   gfc_add_block_to_block (&se->pre, &lse.pre);
1168
1169   /* rhs */
1170   gfc_init_se (&rse, se);
1171   gfc_conv_expr (&rse, expr->value.op.op2);
1172   gfc_add_block_to_block (&se->pre, &rse.pre);
1173
1174   if (checkstring)
1175     {
1176       gfc_conv_string_parameter (&lse);
1177       gfc_conv_string_parameter (&rse);
1178
1179       lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1180                                            rse.string_length, rse.expr);
1181       rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1182       gfc_add_block_to_block (&lse.post, &rse.post);
1183     }
1184
1185   type = gfc_typenode_for_spec (&expr->ts);
1186
1187   if (lop)
1188     {
1189       /* The result of logical ops is always boolean_type_node.  */
1190       tmp = fold_build2 (code, type, lse.expr, rse.expr);
1191       se->expr = convert (type, tmp);
1192     }
1193   else
1194     se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1195
1196   /* Add the post blocks.  */
1197   gfc_add_block_to_block (&se->post, &rse.post);
1198   gfc_add_block_to_block (&se->post, &lse.post);
1199 }
1200
1201 /* If a string's length is one, we convert it to a single character.  */
1202
1203 static tree
1204 gfc_to_single_character (tree len, tree str)
1205 {
1206   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1207
1208   if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1209     && TREE_INT_CST_HIGH (len) == 0)
1210     {
1211       str = fold_convert (pchar_type_node, str);
1212       return build_fold_indirect_ref (str);
1213     }
1214
1215   return NULL_TREE;
1216 }
1217
1218 /* Compare two strings. If they are all single characters, the result is the
1219    subtraction of them. Otherwise, we build a library call.  */
1220
1221 tree
1222 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1223 {
1224   tree sc1;
1225   tree sc2;
1226   tree type;
1227   tree tmp;
1228
1229   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1230   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1231
1232   type = gfc_get_int_type (gfc_default_integer_kind);
1233
1234   sc1 = gfc_to_single_character (len1, str1);
1235   sc2 = gfc_to_single_character (len2, str2);
1236
1237   /* Deal with single character specially.  */
1238   if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1239     {
1240       sc1 = fold_convert (type, sc1);
1241       sc2 = fold_convert (type, sc2);
1242       tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1243     }
1244    else
1245      /* Build a call for the comparison.  */
1246      tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1247                             len1, str1, len2, str2);
1248   return tmp;
1249 }
1250
1251 static void
1252 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1253 {
1254   tree tmp;
1255
1256   if (sym->attr.dummy)
1257     {
1258       tmp = gfc_get_symbol_decl (sym);
1259       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1260               && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1261     }
1262   else
1263     {
1264       if (!sym->backend_decl)
1265         sym->backend_decl = gfc_get_extern_function_decl (sym);
1266
1267       tmp = sym->backend_decl;
1268       if (sym->attr.cray_pointee)
1269         tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1270                        gfc_get_symbol_decl (sym->cp_pointer));
1271       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1272         {
1273           gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1274           tmp = build_fold_addr_expr (tmp);
1275         }
1276     }
1277   se->expr = tmp;
1278 }
1279
1280
1281 /* Translate the call for an elemental subroutine call used in an operator
1282    assignment.  This is a simplified version of gfc_conv_function_call.  */
1283
1284 tree
1285 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1286 {
1287   tree args;
1288   tree tmp;
1289   gfc_se se;
1290   stmtblock_t block;
1291
1292   /* Only elemental subroutines with two arguments.  */
1293   gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1294   gcc_assert (sym->formal->next->next == NULL);
1295
1296   gfc_init_block (&block);
1297
1298   gfc_add_block_to_block (&block, &lse->pre);
1299   gfc_add_block_to_block (&block, &rse->pre);
1300
1301   /* Build the argument list for the call, including hidden string lengths.  */
1302   args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1303   args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1304   if (lse->string_length != NULL_TREE)
1305     args = gfc_chainon_list (args, lse->string_length);
1306   if (rse->string_length != NULL_TREE)
1307     args = gfc_chainon_list (args, rse->string_length);    
1308
1309   /* Build the function call.  */
1310   gfc_init_se (&se, NULL);
1311   gfc_conv_function_val (&se, sym);
1312   tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1313   tmp = build_call_list (tmp, se.expr, args);
1314   gfc_add_expr_to_block (&block, tmp);
1315
1316   gfc_add_block_to_block (&block, &lse->post);
1317   gfc_add_block_to_block (&block, &rse->post);
1318
1319   return gfc_finish_block (&block);
1320 }
1321
1322
1323 /* Initialize MAPPING.  */
1324
1325 void
1326 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1327 {
1328   mapping->syms = NULL;
1329   mapping->charlens = NULL;
1330 }
1331
1332
1333 /* Free all memory held by MAPPING (but not MAPPING itself).  */
1334
1335 void
1336 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1337 {
1338   gfc_interface_sym_mapping *sym;
1339   gfc_interface_sym_mapping *nextsym;
1340   gfc_charlen *cl;
1341   gfc_charlen *nextcl;
1342
1343   for (sym = mapping->syms; sym; sym = nextsym)
1344     {
1345       nextsym = sym->next;
1346       gfc_free_symbol (sym->new->n.sym);
1347       gfc_free (sym->new);
1348       gfc_free (sym);
1349     }
1350   for (cl = mapping->charlens; cl; cl = nextcl)
1351     {
1352       nextcl = cl->next;
1353       gfc_free_expr (cl->length);
1354       gfc_free (cl);
1355     }
1356 }
1357
1358
1359 /* Return a copy of gfc_charlen CL.  Add the returned structure to
1360    MAPPING so that it will be freed by gfc_free_interface_mapping.  */
1361
1362 static gfc_charlen *
1363 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1364                                    gfc_charlen * cl)
1365 {
1366   gfc_charlen *new;
1367
1368   new = gfc_get_charlen ();
1369   new->next = mapping->charlens;
1370   new->length = gfc_copy_expr (cl->length);
1371
1372   mapping->charlens = new;
1373   return new;
1374 }
1375
1376
1377 /* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
1378    array variable that can be used as the actual argument for dummy
1379    argument SYM.  Add any initialization code to BLOCK.  PACKED is as
1380    for gfc_get_nodesc_array_type and DATA points to the first element
1381    in the passed array.  */
1382
1383 static tree
1384 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1385                                  gfc_packed packed, tree data)
1386 {
1387   tree type;
1388   tree var;
1389
1390   type = gfc_typenode_for_spec (&sym->ts);
1391   type = gfc_get_nodesc_array_type (type, sym->as, packed);
1392
1393   var = gfc_create_var (type, "ifm");
1394   gfc_add_modify_expr (block, var, fold_convert (type, data));
1395
1396   return var;
1397 }
1398
1399
1400 /* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
1401    and offset of descriptorless array type TYPE given that it has the same
1402    size as DESC.  Add any set-up code to BLOCK.  */
1403
1404 static void
1405 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1406 {
1407   int n;
1408   tree dim;
1409   tree offset;
1410   tree tmp;
1411
1412   offset = gfc_index_zero_node;
1413   for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1414     {
1415       dim = gfc_rank_cst[n];
1416       GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1417       if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1418         {
1419           GFC_TYPE_ARRAY_LBOUND (type, n)
1420                 = gfc_conv_descriptor_lbound (desc, dim);
1421           GFC_TYPE_ARRAY_UBOUND (type, n)
1422                 = gfc_conv_descriptor_ubound (desc, dim);
1423         }
1424       else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1425         {
1426           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1427                              gfc_conv_descriptor_ubound (desc, dim),
1428                              gfc_conv_descriptor_lbound (desc, dim));
1429           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1430                              GFC_TYPE_ARRAY_LBOUND (type, n),
1431                              tmp);
1432           tmp = gfc_evaluate_now (tmp, block);
1433           GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1434         }
1435       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1436                          GFC_TYPE_ARRAY_LBOUND (type, n),
1437                          GFC_TYPE_ARRAY_STRIDE (type, n));
1438       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1439     }
1440   offset = gfc_evaluate_now (offset, block);
1441   GFC_TYPE_ARRAY_OFFSET (type) = offset;
1442 }
1443
1444
1445 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1446    in SE.  The caller may still use se->expr and se->string_length after
1447    calling this function.  */
1448
1449 void
1450 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1451                            gfc_symbol * sym, gfc_se * se)
1452 {
1453   gfc_interface_sym_mapping *sm;
1454   tree desc;
1455   tree tmp;
1456   tree value;
1457   gfc_symbol *new_sym;
1458   gfc_symtree *root;
1459   gfc_symtree *new_symtree;
1460
1461   /* Create a new symbol to represent the actual argument.  */
1462   new_sym = gfc_new_symbol (sym->name, NULL);
1463   new_sym->ts = sym->ts;
1464   new_sym->attr.referenced = 1;
1465   new_sym->attr.dimension = sym->attr.dimension;
1466   new_sym->attr.pointer = sym->attr.pointer;
1467   new_sym->attr.allocatable = sym->attr.allocatable;
1468   new_sym->attr.flavor = sym->attr.flavor;
1469
1470   /* Create a fake symtree for it.  */
1471   root = NULL;
1472   new_symtree = gfc_new_symtree (&root, sym->name);
1473   new_symtree->n.sym = new_sym;
1474   gcc_assert (new_symtree == root);
1475
1476   /* Create a dummy->actual mapping.  */
1477   sm = gfc_getmem (sizeof (*sm));
1478   sm->next = mapping->syms;
1479   sm->old = sym;
1480   sm->new = new_symtree;
1481   mapping->syms = sm;
1482
1483   /* Stabilize the argument's value.  */
1484   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1485
1486   if (sym->ts.type == BT_CHARACTER)
1487     {
1488       /* Create a copy of the dummy argument's length.  */
1489       new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1490
1491       /* If the length is specified as "*", record the length that
1492          the caller is passing.  We should use the callee's length
1493          in all other cases.  */
1494       if (!new_sym->ts.cl->length)
1495         {
1496           se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1497           new_sym->ts.cl->backend_decl = se->string_length;
1498         }
1499     }
1500
1501   /* Use the passed value as-is if the argument is a function.  */
1502   if (sym->attr.flavor == FL_PROCEDURE)
1503     value = se->expr;
1504
1505   /* If the argument is either a string or a pointer to a string,
1506      convert it to a boundless character type.  */
1507   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1508     {
1509       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1510       tmp = build_pointer_type (tmp);
1511       if (sym->attr.pointer)
1512         value = build_fold_indirect_ref (se->expr);
1513       else
1514         value = se->expr;
1515       value = fold_convert (tmp, value);
1516     }
1517
1518   /* If the argument is a scalar, a pointer to an array or an allocatable,
1519      dereference it.  */
1520   else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1521     value = build_fold_indirect_ref (se->expr);
1522   
1523   /* For character(*), use the actual argument's descriptor.  */  
1524   else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1525     value = build_fold_indirect_ref (se->expr);
1526
1527   /* If the argument is an array descriptor, use it to determine
1528      information about the actual argument's shape.  */
1529   else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1530            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1531     {
1532       /* Get the actual argument's descriptor.  */
1533       desc = build_fold_indirect_ref (se->expr);
1534
1535       /* Create the replacement variable.  */
1536       tmp = gfc_conv_descriptor_data_get (desc);
1537       value = gfc_get_interface_mapping_array (&se->pre, sym,
1538                                                PACKED_NO, tmp);
1539
1540       /* Use DESC to work out the upper bounds, strides and offset.  */
1541       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1542     }
1543   else
1544     /* Otherwise we have a packed array.  */
1545     value = gfc_get_interface_mapping_array (&se->pre, sym,
1546                                              PACKED_FULL, se->expr);
1547
1548   new_sym->backend_decl = value;
1549 }
1550
1551
1552 /* Called once all dummy argument mappings have been added to MAPPING,
1553    but before the mapping is used to evaluate expressions.  Pre-evaluate
1554    the length of each argument, adding any initialization code to PRE and
1555    any finalization code to POST.  */
1556
1557 void
1558 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1559                               stmtblock_t * pre, stmtblock_t * post)
1560 {
1561   gfc_interface_sym_mapping *sym;
1562   gfc_expr *expr;
1563   gfc_se se;
1564
1565   for (sym = mapping->syms; sym; sym = sym->next)
1566     if (sym->new->n.sym->ts.type == BT_CHARACTER
1567         && !sym->new->n.sym->ts.cl->backend_decl)
1568       {
1569         expr = sym->new->n.sym->ts.cl->length;
1570         gfc_apply_interface_mapping_to_expr (mapping, expr);
1571         gfc_init_se (&se, NULL);
1572         gfc_conv_expr (&se, expr);
1573
1574         se.expr = gfc_evaluate_now (se.expr, &se.pre);
1575         gfc_add_block_to_block (pre, &se.pre);
1576         gfc_add_block_to_block (post, &se.post);
1577
1578         sym->new->n.sym->ts.cl->backend_decl = se.expr;
1579       }
1580 }
1581
1582
1583 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1584    constructor C.  */
1585
1586 static void
1587 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1588                                      gfc_constructor * c)
1589 {
1590   for (; c; c = c->next)
1591     {
1592       gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1593       if (c->iterator)
1594         {
1595           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1596           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1597           gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1598         }
1599     }
1600 }
1601
1602
1603 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1604    reference REF.  */
1605
1606 static void
1607 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1608                                     gfc_ref * ref)
1609 {
1610   int n;
1611
1612   for (; ref; ref = ref->next)
1613     switch (ref->type)
1614       {
1615       case REF_ARRAY:
1616         for (n = 0; n < ref->u.ar.dimen; n++)
1617           {
1618             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1619             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1620             gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1621           }
1622         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1623         break;
1624
1625       case REF_COMPONENT:
1626         break;
1627
1628       case REF_SUBSTRING:
1629         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1630         gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1631         break;
1632       }
1633 }
1634
1635
1636 /* EXPR is a copy of an expression that appeared in the interface
1637    associated with MAPPING.  Walk it recursively looking for references to
1638    dummy arguments that MAPPING maps to actual arguments.  Replace each such
1639    reference with a reference to the associated actual argument.  */
1640
1641 static int
1642 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1643                                      gfc_expr * expr)
1644 {
1645   gfc_interface_sym_mapping *sym;
1646   gfc_actual_arglist *actual;
1647   int seen_result = 0;
1648
1649   if (!expr)
1650     return 0;
1651
1652   /* Copying an expression does not copy its length, so do that here.  */
1653   if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1654     {
1655       expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1656       gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1657     }
1658
1659   /* Apply the mapping to any references.  */
1660   gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1661
1662   /* ...and to the expression's symbol, if it has one.  */
1663   if (expr->symtree)
1664     for (sym = mapping->syms; sym; sym = sym->next)
1665       if (sym->old == expr->symtree->n.sym)
1666         expr->symtree = sym->new;
1667
1668   /* ...and to subexpressions in expr->value.  */
1669   switch (expr->expr_type)
1670     {
1671     case EXPR_VARIABLE:
1672       if (expr->symtree->n.sym->attr.result)
1673         seen_result = 1;
1674     case EXPR_CONSTANT:
1675     case EXPR_NULL:
1676     case EXPR_SUBSTRING:
1677       break;
1678
1679     case EXPR_OP:
1680       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1681       gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1682       break;
1683
1684     case EXPR_FUNCTION:
1685       if (expr->value.function.esym == NULL
1686             && expr->value.function.isym != NULL
1687             && expr->value.function.isym->id == GFC_ISYM_LEN
1688             && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1689             && gfc_apply_interface_mapping_to_expr (mapping,
1690                         expr->value.function.actual->expr))
1691         {
1692           gfc_expr *new_expr;
1693           new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1694           *expr = *new_expr;
1695           gfc_free (new_expr);
1696           gfc_apply_interface_mapping_to_expr (mapping, expr);
1697           break;
1698         }
1699
1700       for (sym = mapping->syms; sym; sym = sym->next)
1701         if (sym->old == expr->value.function.esym)
1702           expr->value.function.esym = sym->new->n.sym;
1703
1704       for (actual = expr->value.function.actual; actual; actual = actual->next)
1705         gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1706       break;
1707
1708     case EXPR_ARRAY:
1709     case EXPR_STRUCTURE:
1710       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1711       break;
1712     }
1713   return seen_result;
1714 }
1715
1716
1717 /* Evaluate interface expression EXPR using MAPPING.  Store the result
1718    in SE.  */
1719
1720 void
1721 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1722                              gfc_se * se, gfc_expr * expr)
1723 {
1724   expr = gfc_copy_expr (expr);
1725   gfc_apply_interface_mapping_to_expr (mapping, expr);
1726   gfc_conv_expr (se, expr);
1727   se->expr = gfc_evaluate_now (se->expr, &se->pre);
1728   gfc_free_expr (expr);
1729 }
1730
1731 /* Returns a reference to a temporary array into which a component of
1732    an actual argument derived type array is copied and then returned
1733    after the function call.
1734    TODO Get rid of this kludge, when array descriptors are capable of
1735    handling arrays with a bigger stride in bytes than size.  */
1736
1737 void
1738 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1739                       int g77, sym_intent intent)
1740 {
1741   gfc_se lse;
1742   gfc_se rse;
1743   gfc_ss *lss;
1744   gfc_ss *rss;
1745   gfc_loopinfo loop;
1746   gfc_loopinfo loop2;
1747   gfc_ss_info *info;
1748   tree offset;
1749   tree tmp_index;
1750   tree tmp;
1751   tree base_type;
1752   stmtblock_t body;
1753   int n;
1754
1755   gcc_assert (expr->expr_type == EXPR_VARIABLE);
1756
1757   gfc_init_se (&lse, NULL);
1758   gfc_init_se (&rse, NULL);
1759
1760   /* Walk the argument expression.  */
1761   rss = gfc_walk_expr (expr);
1762
1763   gcc_assert (rss != gfc_ss_terminator);
1764  
1765   /* Initialize the scalarizer.  */
1766   gfc_init_loopinfo (&loop);
1767   gfc_add_ss_to_loop (&loop, rss);
1768
1769   /* Calculate the bounds of the scalarization.  */
1770   gfc_conv_ss_startstride (&loop);
1771
1772   /* Build an ss for the temporary.  */
1773   base_type = gfc_typenode_for_spec (&expr->ts);
1774   if (GFC_ARRAY_TYPE_P (base_type)
1775                 || GFC_DESCRIPTOR_TYPE_P (base_type))
1776     base_type = gfc_get_element_type (base_type);
1777
1778   loop.temp_ss = gfc_get_ss ();;
1779   loop.temp_ss->type = GFC_SS_TEMP;
1780   loop.temp_ss->data.temp.type = base_type;
1781
1782   if (expr->ts.type == BT_CHARACTER)
1783     {
1784       gfc_ref *char_ref = expr->ref;
1785
1786       for (; char_ref; char_ref = char_ref->next)
1787         if (char_ref->type == REF_SUBSTRING)
1788           {
1789             gfc_se tmp_se;
1790
1791             expr->ts.cl = gfc_get_charlen ();
1792             expr->ts.cl->next = char_ref->u.ss.length->next;
1793             char_ref->u.ss.length->next = expr->ts.cl;
1794
1795             gfc_init_se (&tmp_se, NULL);
1796             gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1797                                 gfc_array_index_type);
1798             tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1799                                tmp_se.expr, gfc_index_one_node);
1800             tmp = gfc_evaluate_now (tmp, &parmse->pre);
1801             gfc_init_se (&tmp_se, NULL);
1802             gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1803                                 gfc_array_index_type);
1804             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1805                                tmp, tmp_se.expr);
1806             expr->ts.cl->backend_decl = tmp;
1807
1808             break;
1809           }
1810       loop.temp_ss->data.temp.type
1811                 = gfc_typenode_for_spec (&expr->ts);
1812       loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1813     }
1814
1815   loop.temp_ss->data.temp.dimen = loop.dimen;
1816   loop.temp_ss->next = gfc_ss_terminator;
1817
1818   /* Associate the SS with the loop.  */
1819   gfc_add_ss_to_loop (&loop, loop.temp_ss);
1820
1821   /* Setup the scalarizing loops.  */
1822   gfc_conv_loop_setup (&loop);
1823
1824   /* Pass the temporary descriptor back to the caller.  */
1825   info = &loop.temp_ss->data.info;
1826   parmse->expr = info->descriptor;
1827
1828   /* Setup the gfc_se structures.  */
1829   gfc_copy_loopinfo_to_se (&lse, &loop);
1830   gfc_copy_loopinfo_to_se (&rse, &loop);
1831
1832   rse.ss = rss;
1833   lse.ss = loop.temp_ss;
1834   gfc_mark_ss_chain_used (rss, 1);
1835   gfc_mark_ss_chain_used (loop.temp_ss, 1);
1836
1837   /* Start the scalarized loop body.  */
1838   gfc_start_scalarized_body (&loop, &body);
1839
1840   /* Translate the expression.  */
1841   gfc_conv_expr (&rse, expr);
1842
1843   gfc_conv_tmp_array_ref (&lse);
1844   gfc_advance_se_ss_chain (&lse);
1845
1846   if (intent != INTENT_OUT)
1847     {
1848       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1849       gfc_add_expr_to_block (&body, tmp);
1850       gcc_assert (rse.ss == gfc_ss_terminator);
1851       gfc_trans_scalarizing_loops (&loop, &body);
1852     }
1853   else
1854     {
1855       /* Make sure that the temporary declaration survives by merging
1856        all the loop declarations into the current context.  */
1857       for (n = 0; n < loop.dimen; n++)
1858         {
1859           gfc_merge_block_scope (&body);
1860           body = loop.code[loop.order[n]];
1861         }
1862       gfc_merge_block_scope (&body);
1863     }
1864
1865   /* Add the post block after the second loop, so that any
1866      freeing of allocated memory is done at the right time.  */
1867   gfc_add_block_to_block (&parmse->pre, &loop.pre);
1868
1869   /**********Copy the temporary back again.*********/
1870
1871   gfc_init_se (&lse, NULL);
1872   gfc_init_se (&rse, NULL);
1873
1874   /* Walk the argument expression.  */
1875   lss = gfc_walk_expr (expr);
1876   rse.ss = loop.temp_ss;
1877   lse.ss = lss;
1878
1879   /* Initialize the scalarizer.  */
1880   gfc_init_loopinfo (&loop2);
1881   gfc_add_ss_to_loop (&loop2, lss);
1882
1883   /* Calculate the bounds of the scalarization.  */
1884   gfc_conv_ss_startstride (&loop2);
1885
1886   /* Setup the scalarizing loops.  */
1887   gfc_conv_loop_setup (&loop2);
1888
1889   gfc_copy_loopinfo_to_se (&lse, &loop2);
1890   gfc_copy_loopinfo_to_se (&rse, &loop2);
1891
1892   gfc_mark_ss_chain_used (lss, 1);
1893   gfc_mark_ss_chain_used (loop.temp_ss, 1);
1894
1895   /* Declare the variable to hold the temporary offset and start the
1896      scalarized loop body.  */
1897   offset = gfc_create_var (gfc_array_index_type, NULL);
1898   gfc_start_scalarized_body (&loop2, &body);
1899
1900   /* Build the offsets for the temporary from the loop variables.  The
1901      temporary array has lbounds of zero and strides of one in all
1902      dimensions, so this is very simple.  The offset is only computed
1903      outside the innermost loop, so the overall transfer could be
1904      optimized further.  */
1905   info = &rse.ss->data.info;
1906
1907   tmp_index = gfc_index_zero_node;
1908   for (n = info->dimen - 1; n > 0; n--)
1909     {
1910       tree tmp_str;
1911       tmp = rse.loop->loopvar[n];
1912       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1913                          tmp, rse.loop->from[n]);
1914       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1915                          tmp, tmp_index);
1916
1917       tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1918                              rse.loop->to[n-1], rse.loop->from[n-1]);
1919       tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1920                              tmp_str, gfc_index_one_node);
1921
1922       tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1923                                tmp, tmp_str);
1924     }
1925
1926   tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1927                            tmp_index, rse.loop->from[0]);
1928   gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1929
1930   tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1931                            rse.loop->loopvar[0], offset);
1932
1933   /* Now use the offset for the reference.  */
1934   tmp = build_fold_indirect_ref (info->data);
1935   rse.expr = gfc_build_array_ref (tmp, tmp_index);
1936
1937   if (expr->ts.type == BT_CHARACTER)
1938     rse.string_length = expr->ts.cl->backend_decl;
1939
1940   gfc_conv_expr (&lse, expr);
1941
1942   gcc_assert (lse.ss == gfc_ss_terminator);
1943
1944   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1945   gfc_add_expr_to_block (&body, tmp);
1946   
1947   /* Generate the copying loops.  */
1948   gfc_trans_scalarizing_loops (&loop2, &body);
1949
1950   /* Wrap the whole thing up by adding the second loop to the post-block
1951      and following it by the post-block of the first loop.  In this way,
1952      if the temporary needs freeing, it is done after use!  */
1953   if (intent != INTENT_IN)
1954     {
1955       gfc_add_block_to_block (&parmse->post, &loop2.pre);
1956       gfc_add_block_to_block (&parmse->post, &loop2.post);
1957     }
1958
1959   gfc_add_block_to_block (&parmse->post, &loop.post);
1960
1961   gfc_cleanup_loop (&loop);
1962   gfc_cleanup_loop (&loop2);
1963
1964   /* Pass the string length to the argument expression.  */
1965   if (expr->ts.type == BT_CHARACTER)
1966     parmse->string_length = expr->ts.cl->backend_decl;
1967
1968   /* We want either the address for the data or the address of the descriptor,
1969      depending on the mode of passing array arguments.  */
1970   if (g77)
1971     parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1972   else
1973     parmse->expr = build_fold_addr_expr (parmse->expr);
1974
1975   return;
1976 }
1977
1978 /* Is true if an array reference is followed by a component or substring
1979    reference.  */
1980
1981 bool
1982 is_aliased_array (gfc_expr * e)
1983 {
1984   gfc_ref * ref;
1985   bool seen_array;
1986
1987   seen_array = false;   
1988   for (ref = e->ref; ref; ref = ref->next)
1989     {
1990       if (ref->type == REF_ARRAY
1991             && ref->u.ar.type != AR_ELEMENT)
1992         seen_array = true;
1993
1994       if (seen_array
1995             && ref->type != REF_ARRAY)
1996         return seen_array;
1997     }
1998   return false;
1999 }
2000
2001 /* Generate the code for argument list functions.  */
2002
2003 static void
2004 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2005 {
2006   /* Pass by value for g77 %VAL(arg), pass the address
2007      indirectly for %LOC, else by reference.  Thus %REF
2008      is a "do-nothing" and %LOC is the same as an F95
2009      pointer.  */
2010   if (strncmp (name, "%VAL", 4) == 0)
2011     gfc_conv_expr (se, expr);
2012   else if (strncmp (name, "%LOC", 4) == 0)
2013     {
2014       gfc_conv_expr_reference (se, expr);
2015       se->expr = gfc_build_addr_expr (NULL, se->expr);
2016     }
2017   else if (strncmp (name, "%REF", 4) == 0)
2018     gfc_conv_expr_reference (se, expr);
2019   else
2020     gfc_error ("Unknown argument list function at %L", &expr->where);
2021 }
2022
2023
2024 /* Generate code for a procedure call.  Note can return se->post != NULL.
2025    If se->direct_byref is set then se->expr contains the return parameter.
2026    Return nonzero, if the call has alternate specifiers.  */
2027
2028 int
2029 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2030                         gfc_actual_arglist * arg, tree append_args)
2031 {
2032   gfc_interface_mapping mapping;
2033   tree arglist;
2034   tree retargs;
2035   tree tmp;
2036   tree fntype;
2037   gfc_se parmse;
2038   gfc_ss *argss;
2039   gfc_ss_info *info;
2040   int byref;
2041   int parm_kind;
2042   tree type;
2043   tree var;
2044   tree len;
2045   tree stringargs;
2046   gfc_formal_arglist *formal;
2047   int has_alternate_specifier = 0;
2048   bool need_interface_mapping;
2049   bool callee_alloc;
2050   gfc_typespec ts;
2051   gfc_charlen cl;
2052   gfc_expr *e;
2053   gfc_symbol *fsym;
2054   stmtblock_t post;
2055   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2056
2057   arglist = NULL_TREE;
2058   retargs = NULL_TREE;
2059   stringargs = NULL_TREE;
2060   var = NULL_TREE;
2061   len = NULL_TREE;
2062
2063   if (sym->from_intmod == INTMOD_ISO_C_BINDING
2064       && sym->intmod_sym_id == ISOCBINDING_LOC)
2065     {
2066       if (arg->expr->rank == 0)
2067         {
2068           gfc_conv_expr_reference (se, arg->expr);
2069         }
2070       else
2071         {
2072           int f;
2073           /* This is really the actual arg because no formal arglist is
2074              created for C_LOC.  */
2075           fsym = arg->expr->symtree->n.sym;
2076
2077           /* We should want it to do g77 calling convention.  */
2078           f = (fsym != NULL)
2079             && !(fsym->attr.pointer || fsym->attr.allocatable)
2080             && fsym->as->type != AS_ASSUMED_SHAPE;
2081           f = f || !sym->attr.always_explicit;
2082           
2083           argss = gfc_walk_expr (arg->expr);
2084           gfc_conv_array_parameter (se, arg->expr, argss, f);
2085         }
2086
2087       return 0;
2088     }
2089   
2090   if (se->ss != NULL)
2091     {
2092       if (!sym->attr.elemental)
2093         {
2094           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2095           if (se->ss->useflags)
2096             {
2097               gcc_assert (gfc_return_by_reference (sym)
2098                       && sym->result->attr.dimension);
2099               gcc_assert (se->loop != NULL);
2100
2101               /* Access the previously obtained result.  */
2102               gfc_conv_tmp_array_ref (se);
2103               gfc_advance_se_ss_chain (se);
2104               return 0;
2105             }
2106         }
2107       info = &se->ss->data.info;
2108     }
2109   else
2110     info = NULL;
2111
2112   gfc_init_block (&post);
2113   gfc_init_interface_mapping (&mapping);
2114   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2115                                   && sym->ts.cl->length
2116                                   && sym->ts.cl->length->expr_type
2117                                                 != EXPR_CONSTANT)
2118                               || sym->attr.dimension);
2119   formal = sym->formal;
2120   /* Evaluate the arguments.  */
2121   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2122     {
2123       e = arg->expr;
2124       fsym = formal ? formal->sym : NULL;
2125       parm_kind = MISSING;
2126       if (e == NULL)
2127         {
2128
2129           if (se->ignore_optional)
2130             {
2131               /* Some intrinsics have already been resolved to the correct
2132                  parameters.  */
2133               continue;
2134             }
2135           else if (arg->label)
2136             {
2137               has_alternate_specifier = 1;
2138               continue;
2139             }
2140           else
2141             {
2142               /* Pass a NULL pointer for an absent arg.  */
2143               gfc_init_se (&parmse, NULL);
2144               parmse.expr = null_pointer_node;
2145               if (arg->missing_arg_type == BT_CHARACTER)
2146                 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2147             }
2148         }
2149       else if (se->ss && se->ss->useflags)
2150         {
2151           /* An elemental function inside a scalarized loop.  */
2152           gfc_init_se (&parmse, se);
2153           gfc_conv_expr_reference (&parmse, e);
2154           parm_kind = ELEMENTAL;
2155         }
2156       else
2157         {
2158           /* A scalar or transformational function.  */
2159           gfc_init_se (&parmse, NULL);
2160           argss = gfc_walk_expr (e);
2161
2162           if (argss == gfc_ss_terminator)
2163             {
2164               if (fsym && fsym->attr.value)
2165                 {
2166                   gfc_conv_expr (&parmse, e);
2167                 }
2168               else if (arg->name && arg->name[0] == '%')
2169                 /* Argument list functions %VAL, %LOC and %REF are signalled
2170                    through arg->name.  */
2171                 conv_arglist_function (&parmse, arg->expr, arg->name);
2172               else if ((e->expr_type == EXPR_FUNCTION)
2173                           && e->symtree->n.sym->attr.pointer
2174                           && fsym && fsym->attr.target)
2175                 {
2176                   gfc_conv_expr (&parmse, e);
2177                   parmse.expr = build_fold_addr_expr (parmse.expr);
2178                 }
2179               else
2180                 {
2181                   gfc_conv_expr_reference (&parmse, e);
2182                   if (fsym && fsym->attr.pointer
2183                       && fsym->attr.flavor != FL_PROCEDURE
2184                       && e->expr_type != EXPR_NULL)
2185                     {
2186                       /* Scalar pointer dummy args require an extra level of
2187                          indirection. The null pointer already contains
2188                          this level of indirection.  */
2189                       parm_kind = SCALAR_POINTER;
2190                       parmse.expr = build_fold_addr_expr (parmse.expr);
2191                     }
2192                 }
2193             }
2194           else
2195             {
2196               /* If the procedure requires an explicit interface, the actual
2197                  argument is passed according to the corresponding formal
2198                  argument.  If the corresponding formal argument is a POINTER,
2199                  ALLOCATABLE or assumed shape, we do not use g77's calling
2200                  convention, and pass the address of the array descriptor
2201                  instead. Otherwise we use g77's calling convention.  */
2202               int f;
2203               f = (fsym != NULL)
2204                   && !(fsym->attr.pointer || fsym->attr.allocatable)
2205                   && fsym->as->type != AS_ASSUMED_SHAPE;
2206               f = f || !sym->attr.always_explicit;
2207
2208               if (e->expr_type == EXPR_VARIABLE
2209                     && is_aliased_array (e))
2210                 /* The actual argument is a component reference to an
2211                    array of derived types.  In this case, the argument
2212                    is converted to a temporary, which is passed and then
2213                    written back after the procedure call.  */
2214                 gfc_conv_aliased_arg (&parmse, e, f,
2215                         fsym ? fsym->attr.intent : INTENT_INOUT);
2216               else
2217                 gfc_conv_array_parameter (&parmse, e, argss, f);
2218
2219               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
2220                  allocated on entry, it must be deallocated.  */
2221               if (fsym && fsym->attr.allocatable
2222                   && fsym->attr.intent == INTENT_OUT)
2223                 {
2224                   tmp = build_fold_indirect_ref (parmse.expr);
2225                   tmp = gfc_trans_dealloc_allocated (tmp);
2226                   gfc_add_expr_to_block (&se->pre, tmp);
2227                 }
2228
2229             } 
2230         }
2231
2232       if (fsym)
2233         {
2234           if (e)
2235             {
2236               /* If an optional argument is itself an optional dummy
2237                  argument, check its presence and substitute a null
2238                  if absent.  */
2239               if (e->expr_type == EXPR_VARIABLE
2240                     && e->symtree->n.sym->attr.optional
2241                     && fsym->attr.optional)
2242                 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2243
2244               /* If an INTENT(OUT) dummy of derived type has a default
2245                  initializer, it must be (re)initialized here.  */
2246               if (fsym->attr.intent == INTENT_OUT
2247                     && fsym->ts.type == BT_DERIVED
2248                     && fsym->value)
2249                 {
2250                   gcc_assert (!fsym->attr.allocatable);
2251                   tmp = gfc_trans_assignment (e, fsym->value, false);
2252                   gfc_add_expr_to_block (&se->pre, tmp);
2253                 }
2254
2255               /* Obtain the character length of an assumed character
2256                  length procedure from the typespec.  */
2257               if (fsym->ts.type == BT_CHARACTER
2258                     && parmse.string_length == NULL_TREE
2259                     && e->ts.type == BT_PROCEDURE
2260                     && e->symtree->n.sym->ts.type == BT_CHARACTER
2261                     && e->symtree->n.sym->ts.cl->length != NULL)
2262                 {
2263                   gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2264                   parmse.string_length
2265                         = e->symtree->n.sym->ts.cl->backend_decl;
2266                 }
2267             }
2268
2269           if (need_interface_mapping)
2270             gfc_add_interface_mapping (&mapping, fsym, &parmse);
2271         }
2272
2273       gfc_add_block_to_block (&se->pre, &parmse.pre);
2274       gfc_add_block_to_block (&post, &parmse.post);
2275
2276       /* Allocated allocatable components of derived types must be
2277          deallocated for INTENT(OUT) dummy arguments and non-variable
2278          scalars.  Non-variable arrays are dealt with in trans-array.c
2279          (gfc_conv_array_parameter).  */
2280       if (e && e->ts.type == BT_DERIVED
2281             && e->ts.derived->attr.alloc_comp
2282             && ((formal && formal->sym->attr.intent == INTENT_OUT)
2283                    ||
2284                 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2285         {
2286           int parm_rank;
2287           tmp = build_fold_indirect_ref (parmse.expr);
2288           parm_rank = e->rank;
2289           switch (parm_kind)
2290             {
2291             case (ELEMENTAL):
2292             case (SCALAR):
2293               parm_rank = 0;
2294               break;
2295
2296             case (SCALAR_POINTER):
2297               tmp = build_fold_indirect_ref (tmp);
2298               break;
2299             case (ARRAY):
2300               tmp = parmse.expr;
2301               break;
2302             }
2303
2304           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2305           if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2306             tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2307                             tmp, build_empty_stmt ());
2308
2309           if (e->expr_type != EXPR_VARIABLE)
2310             /* Don't deallocate non-variables until they have been used.  */
2311             gfc_add_expr_to_block (&se->post, tmp);
2312           else 
2313             {
2314               gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2315               gfc_add_expr_to_block (&se->pre, tmp);
2316             }
2317         }
2318
2319       /* Character strings are passed as two parameters, a length and a
2320          pointer.  */
2321       if (parmse.string_length != NULL_TREE)
2322         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2323
2324       arglist = gfc_chainon_list (arglist, parmse.expr);
2325     }
2326   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2327
2328   ts = sym->ts;
2329   if (ts.type == BT_CHARACTER)
2330     {
2331       if (sym->ts.cl->length == NULL)
2332         {
2333           /* Assumed character length results are not allowed by 5.1.1.5 of the
2334              standard and are trapped in resolve.c; except in the case of SPREAD
2335              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
2336              we take the character length of the first argument for the result.
2337              For dummies, we have to look through the formal argument list for
2338              this function and use the character length found there.*/
2339           if (!sym->attr.dummy)
2340             cl.backend_decl = TREE_VALUE (stringargs);
2341           else
2342             {
2343               formal = sym->ns->proc_name->formal;
2344               for (; formal; formal = formal->next)
2345                 if (strcmp (formal->sym->name, sym->name) == 0)
2346                   cl.backend_decl = formal->sym->ts.cl->backend_decl;
2347             }
2348         }
2349         else
2350         {
2351           tree tmp;
2352
2353           /* Calculate the length of the returned string.  */
2354           gfc_init_se (&parmse, NULL);
2355           if (need_interface_mapping)
2356             gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2357           else
2358             gfc_conv_expr (&parmse, sym->ts.cl->length);
2359           gfc_add_block_to_block (&se->pre, &parmse.pre);
2360           gfc_add_block_to_block (&se->post, &parmse.post);
2361           
2362           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2363           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2364                              build_int_cst (gfc_charlen_type_node, 0));
2365           cl.backend_decl = tmp;
2366         }
2367
2368       /* Set up a charlen structure for it.  */
2369       cl.next = NULL;
2370       cl.length = NULL;
2371       ts.cl = &cl;
2372
2373       len = cl.backend_decl;
2374     }
2375
2376   byref = gfc_return_by_reference (sym);
2377   if (byref)
2378     {
2379       if (se->direct_byref)
2380         {
2381           /* Sometimes, too much indirection can be applied; eg. for
2382              function_result = array_valued_recursive_function.  */
2383           if (TREE_TYPE (TREE_TYPE (se->expr))
2384                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2385                 && GFC_DESCRIPTOR_TYPE_P
2386                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2387             se->expr = build_fold_indirect_ref (se->expr);
2388
2389           retargs = gfc_chainon_list (retargs, se->expr);
2390         }
2391       else if (sym->result->attr.dimension)
2392         {
2393           gcc_assert (se->loop && info);
2394
2395           /* Set the type of the array.  */
2396           tmp = gfc_typenode_for_spec (&ts);
2397           info->dimen = se->loop->dimen;
2398
2399           /* Evaluate the bounds of the result, if known.  */
2400           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2401
2402           /* Create a temporary to store the result.  In case the function
2403              returns a pointer, the temporary will be a shallow copy and
2404              mustn't be deallocated.  */
2405           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2406           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2407                                        false, !sym->attr.pointer, callee_alloc);
2408
2409           /* Pass the temporary as the first argument.  */
2410           tmp = info->descriptor;
2411           tmp = build_fold_addr_expr (tmp);
2412           retargs = gfc_chainon_list (retargs, tmp);
2413         }
2414       else if (ts.type == BT_CHARACTER)
2415         {
2416           /* Pass the string length.  */
2417           type = gfc_get_character_type (ts.kind, ts.cl);
2418           type = build_pointer_type (type);
2419
2420           /* Return an address to a char[0:len-1]* temporary for
2421              character pointers.  */
2422           if (sym->attr.pointer || sym->attr.allocatable)
2423             {
2424               /* Build char[0:len-1] * pstr.  */
2425               tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2426                                  build_int_cst (gfc_charlen_type_node, 1));
2427               tmp = build_range_type (gfc_array_index_type,
2428                                       gfc_index_zero_node, tmp);
2429               tmp = build_array_type (gfc_character1_type_node, tmp);
2430               var = gfc_create_var (build_pointer_type (tmp), "pstr");
2431
2432               /* Provide an address expression for the function arguments.  */
2433               var = build_fold_addr_expr (var);
2434             }
2435           else
2436             var = gfc_conv_string_tmp (se, type, len);
2437
2438           retargs = gfc_chainon_list (retargs, var);
2439         }
2440       else
2441         {
2442           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2443
2444           type = gfc_get_complex_type (ts.kind);
2445           var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2446           retargs = gfc_chainon_list (retargs, var);
2447         }
2448
2449       /* Add the string length to the argument list.  */
2450       if (ts.type == BT_CHARACTER)
2451         retargs = gfc_chainon_list (retargs, len);
2452     }
2453   gfc_free_interface_mapping (&mapping);
2454
2455   /* Add the return arguments.  */
2456   arglist = chainon (retargs, arglist);
2457
2458   /* Add the hidden string length parameters to the arguments.  */
2459   arglist = chainon (arglist, stringargs);
2460
2461   /* We may want to append extra arguments here.  This is used e.g. for
2462      calls to libgfortran_matmul_??, which need extra information.  */
2463   if (append_args != NULL_TREE)
2464     arglist = chainon (arglist, append_args);
2465
2466   /* Generate the actual call.  */
2467   gfc_conv_function_val (se, sym);
2468
2469   /* If there are alternate return labels, function type should be
2470      integer.  Can't modify the type in place though, since it can be shared
2471      with other functions.  For dummy arguments, the typing is done to
2472      to this result, even if it has to be repeated for each call.  */
2473   if (has_alternate_specifier
2474       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2475     {
2476       if (!sym->attr.dummy)
2477         {
2478           TREE_TYPE (sym->backend_decl)
2479                 = build_function_type (integer_type_node,
2480                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2481           se->expr = build_fold_addr_expr (sym->backend_decl);
2482         }
2483       else
2484         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2485     }
2486
2487   fntype = TREE_TYPE (TREE_TYPE (se->expr));
2488   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2489
2490   /* If we have a pointer function, but we don't want a pointer, e.g.
2491      something like
2492         x = f()
2493      where f is pointer valued, we have to dereference the result.  */
2494   if (!se->want_pointer && !byref && sym->attr.pointer)
2495     se->expr = build_fold_indirect_ref (se->expr);
2496
2497   /* f2c calling conventions require a scalar default real function to
2498      return a double precision result.  Convert this back to default
2499      real.  We only care about the cases that can happen in Fortran 77.
2500   */
2501   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2502       && sym->ts.kind == gfc_default_real_kind
2503       && !sym->attr.always_explicit)
2504     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2505
2506   /* A pure function may still have side-effects - it may modify its
2507      parameters.  */
2508   TREE_SIDE_EFFECTS (se->expr) = 1;
2509 #if 0
2510   if (!sym->attr.pure)
2511     TREE_SIDE_EFFECTS (se->expr) = 1;
2512 #endif
2513
2514   if (byref)
2515     {
2516       /* Add the function call to the pre chain.  There is no expression.  */
2517       gfc_add_expr_to_block (&se->pre, se->expr);
2518       se->expr = NULL_TREE;
2519
2520       if (!se->direct_byref)
2521         {
2522           if (sym->attr.dimension)
2523             {
2524               if (flag_bounds_check)
2525                 {
2526                   /* Check the data pointer hasn't been modified.  This would
2527                      happen in a function returning a pointer.  */
2528                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2529                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
2530                                      tmp, info->data);
2531                   gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2532                 }
2533               se->expr = info->descriptor;
2534               /* Bundle in the string length.  */
2535               se->string_length = len;
2536             }
2537           else if (sym->ts.type == BT_CHARACTER)
2538             {
2539               /* Dereference for character pointer results.  */
2540               if (sym->attr.pointer || sym->attr.allocatable)
2541                 se->expr = build_fold_indirect_ref (var);
2542               else
2543                 se->expr = var;
2544
2545               se->string_length = len;
2546             }
2547           else
2548             {
2549               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2550               se->expr = build_fold_indirect_ref (var);
2551             }
2552         }
2553     }
2554
2555   /* Follow the function call with the argument post block.  */
2556   if (byref)
2557     gfc_add_block_to_block (&se->pre, &post);
2558   else
2559     gfc_add_block_to_block (&se->post, &post);
2560
2561   return has_alternate_specifier;
2562 }
2563
2564
2565 /* Generate code to copy a string.  */
2566
2567 static void
2568 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2569                        tree slength, tree src)
2570 {
2571   tree tmp, dlen, slen;
2572   tree dsc;
2573   tree ssc;
2574   tree cond;
2575   tree cond2;
2576   tree tmp2;
2577   tree tmp3;
2578   tree tmp4;
2579   stmtblock_t tempblock;
2580
2581   dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2582   slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2583
2584   /* Deal with single character specially.  */
2585   dsc = gfc_to_single_character (dlen, dest);
2586   ssc = gfc_to_single_character (slen, src);
2587   if (dsc != NULL_TREE && ssc != NULL_TREE)
2588     {
2589       gfc_add_modify_expr (block, dsc, ssc);
2590       return;
2591     }
2592
2593   /* Do nothing if the destination length is zero.  */
2594   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2595                       build_int_cst (size_type_node, 0));
2596
2597   /* The following code was previously in _gfortran_copy_string:
2598
2599        // The two strings may overlap so we use memmove.
2600        void
2601        copy_string (GFC_INTEGER_4 destlen, char * dest,
2602                     GFC_INTEGER_4 srclen, const char * src)
2603        {
2604          if (srclen >= destlen)
2605            {
2606              // This will truncate if too long.
2607              memmove (dest, src, destlen);
2608            }
2609          else
2610            {
2611              memmove (dest, src, srclen);
2612              // Pad with spaces.
2613              memset (&dest[srclen], ' ', destlen - srclen);
2614            }
2615        }
2616
2617      We're now doing it here for better optimization, but the logic
2618      is the same.  */
2619   
2620   /* Truncate string if source is too long.  */
2621   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2622   tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2623                           3, dest, src, dlen);
2624
2625   /* Else copy and pad with spaces.  */
2626   tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2627                           3, dest, src, slen);
2628
2629   tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
2630                       fold_convert (sizetype, slen));
2631   tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2632                           tmp4, 
2633                           build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2634                                          lang_hooks.to_target_charset (' ')),
2635                           fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2636                                        dlen, slen));
2637
2638   gfc_init_block (&tempblock);
2639   gfc_add_expr_to_block (&tempblock, tmp3);
2640   gfc_add_expr_to_block (&tempblock, tmp4);
2641   tmp3 = gfc_finish_block (&tempblock);
2642
2643   /* The whole copy_string function is there.  */
2644   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2645   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2646   gfc_add_expr_to_block (block, tmp);
2647 }
2648
2649
2650 /* Translate a statement function.
2651    The value of a statement function reference is obtained by evaluating the
2652    expression using the values of the actual arguments for the values of the
2653    corresponding dummy arguments.  */
2654
2655 static void
2656 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2657 {
2658   gfc_symbol *sym;
2659   gfc_symbol *fsym;
2660   gfc_formal_arglist *fargs;
2661   gfc_actual_arglist *args;
2662   gfc_se lse;
2663   gfc_se rse;
2664   gfc_saved_var *saved_vars;
2665   tree *temp_vars;
2666   tree type;
2667   tree tmp;
2668   int n;
2669
2670   sym = expr->symtree->n.sym;
2671   args = expr->value.function.actual;
2672   gfc_init_se (&lse, NULL);
2673   gfc_init_se (&rse, NULL);
2674
2675   n = 0;
2676   for (fargs = sym->formal; fargs; fargs = fargs->next)
2677     n++;
2678   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2679   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2680
2681   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2682     {
2683       /* Each dummy shall be specified, explicitly or implicitly, to be
2684          scalar.  */
2685       gcc_assert (fargs->sym->attr.dimension == 0);
2686       fsym = fargs->sym;
2687
2688       /* Create a temporary to hold the value.  */
2689       type = gfc_typenode_for_spec (&fsym->ts);
2690       temp_vars[n] = gfc_create_var (type, fsym->name);
2691
2692       if (fsym->ts.type == BT_CHARACTER)
2693         {
2694           /* Copy string arguments.  */
2695           tree arglen;
2696
2697           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2698                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2699
2700           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2701           tmp = gfc_build_addr_expr (build_pointer_type (type),
2702                                      temp_vars[n]);
2703
2704           gfc_conv_expr (&rse, args->expr);
2705           gfc_conv_string_parameter (&rse);
2706           gfc_add_block_to_block (&se->pre, &lse.pre);
2707           gfc_add_block_to_block (&se->pre, &rse.pre);
2708
2709           gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2710                                  rse.expr);
2711           gfc_add_block_to_block (&se->pre, &lse.post);
2712           gfc_add_block_to_block (&se->pre, &rse.post);
2713         }
2714       else
2715         {
2716           /* For everything else, just evaluate the expression.  */
2717           gfc_conv_expr (&lse, args->expr);
2718
2719           gfc_add_block_to_block (&se->pre, &lse.pre);
2720           gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2721           gfc_add_block_to_block (&se->pre, &lse.post);
2722         }
2723
2724       args = args->next;
2725     }
2726
2727   /* Use the temporary variables in place of the real ones.  */
2728   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2729     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2730
2731   gfc_conv_expr (se, sym->value);
2732
2733   if (sym->ts.type == BT_CHARACTER)
2734     {
2735       gfc_conv_const_charlen (sym->ts.cl);
2736
2737       /* Force the expression to the correct length.  */
2738       if (!INTEGER_CST_P (se->string_length)
2739           || tree_int_cst_lt (se->string_length,
2740                               sym->ts.cl->backend_decl))
2741         {
2742           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2743           tmp = gfc_create_var (type, sym->name);
2744           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2745           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2746                                  se->string_length, se->expr);
2747           se->expr = tmp;
2748         }
2749       se->string_length = sym->ts.cl->backend_decl;
2750     }
2751
2752   /* Restore the original variables.  */
2753   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2754     gfc_restore_sym (fargs->sym, &saved_vars[n]);
2755   gfc_free (saved_vars);
2756 }
2757
2758
2759 /* Translate a function expression.  */
2760
2761 static void
2762 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2763 {
2764   gfc_symbol *sym;
2765
2766   if (expr->value.function.isym)
2767     {
2768       gfc_conv_intrinsic_function (se, expr);
2769       return;
2770     }
2771
2772   /* We distinguish statement functions from general functions to improve
2773      runtime performance.  */
2774   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2775     {
2776       gfc_conv_statement_function (se, expr);
2777       return;
2778     }
2779
2780   /* expr.value.function.esym is the resolved (specific) function symbol for
2781      most functions.  However this isn't set for dummy procedures.  */
2782   sym = expr->value.function.esym;
2783   if (!sym)
2784     sym = expr->symtree->n.sym;
2785   gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2786 }
2787
2788
2789 static void
2790 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2791 {
2792   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2793   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2794
2795   gfc_conv_tmp_array_ref (se);
2796   gfc_advance_se_ss_chain (se);
2797 }
2798
2799
2800 /* Build a static initializer.  EXPR is the expression for the initial value.
2801    The other parameters describe the variable of the component being 
2802    initialized. EXPR may be null.  */
2803
2804 tree
2805 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2806                       bool array, bool pointer)
2807 {
2808   gfc_se se;
2809
2810   if (!(expr || pointer))
2811     return NULL_TREE;
2812
2813   if (expr != NULL && expr->ts.type == BT_DERIVED
2814       && expr->ts.is_iso_c && expr->ts.derived
2815       && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
2816           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
2817       expr = gfc_int_expr (0);
2818   
2819   if (array)
2820     {
2821       /* Arrays need special handling.  */
2822       if (pointer)
2823         return gfc_build_null_descriptor (type);
2824       else
2825         return gfc_conv_array_initializer (type, expr);
2826     }
2827   else if (pointer)
2828     return fold_convert (type, null_pointer_node);
2829   else
2830     {
2831       switch (ts->type)
2832         {
2833         case BT_DERIVED:
2834           gfc_init_se (&se, NULL);
2835           gfc_conv_structure (&se, expr, 1);
2836           return se.expr;
2837
2838         case BT_CHARACTER:
2839           return gfc_conv_string_init (ts->cl->backend_decl,expr);
2840
2841         default:
2842           gfc_init_se (&se, NULL);
2843           gfc_conv_constant (&se, expr);
2844           return se.expr;
2845         }
2846     }
2847 }
2848   
2849 static tree
2850 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2851 {
2852   gfc_se rse;
2853   gfc_se lse;
2854   gfc_ss *rss;
2855   gfc_ss *lss;
2856   stmtblock_t body;
2857   stmtblock_t block;
2858   gfc_loopinfo loop;
2859   int n;
2860   tree tmp;
2861
2862   gfc_start_block (&block);
2863
2864   /* Initialize the scalarizer.  */
2865   gfc_init_loopinfo (&loop);
2866
2867   gfc_init_se (&lse, NULL);
2868   gfc_init_se (&rse, NULL);
2869
2870   /* Walk the rhs.  */
2871   rss = gfc_walk_expr (expr);
2872   if (rss == gfc_ss_terminator)
2873     {
2874       /* The rhs is scalar.  Add a ss for the expression.  */
2875       rss = gfc_get_ss ();
2876       rss->next = gfc_ss_terminator;
2877       rss->type = GFC_SS_SCALAR;
2878       rss->expr = expr;
2879     }
2880
2881   /* Create a SS for the destination.  */
2882   lss = gfc_get_ss ();
2883   lss->type = GFC_SS_COMPONENT;
2884   lss->expr = NULL;
2885   lss->shape = gfc_get_shape (cm->as->rank);
2886   lss->next = gfc_ss_terminator;
2887   lss->data.info.dimen = cm->as->rank;
2888   lss->data.info.descriptor = dest;
2889   lss->data.info.data = gfc_conv_array_data (dest);
2890   lss->data.info.offset = gfc_conv_array_offset (dest);
2891   for (n = 0; n < cm->as->rank; n++)
2892     {
2893       lss->data.info.dim[n] = n;
2894       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2895       lss->data.info.stride[n] = gfc_index_one_node;
2896
2897       mpz_init (lss->shape[n]);
2898       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2899                cm->as->lower[n]->value.integer);
2900       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2901     }
2902   
2903   /* Associate the SS with the loop.  */
2904   gfc_add_ss_to_loop (&loop, lss);
2905   gfc_add_ss_to_loop (&loop, rss);
2906
2907   /* Calculate the bounds of the scalarization.  */
2908   gfc_conv_ss_startstride (&loop);
2909
2910   /* Setup the scalarizing loops.  */
2911   gfc_conv_loop_setup (&loop);
2912
2913   /* Setup the gfc_se structures.  */
2914   gfc_copy_loopinfo_to_se (&lse, &loop);
2915   gfc_copy_loopinfo_to_se (&rse, &loop);
2916
2917   rse.ss = rss;
2918   gfc_mark_ss_chain_used (rss, 1);
2919   lse.ss = lss;
2920   gfc_mark_ss_chain_used (lss, 1);
2921
2922   /* Start the scalarized loop body.  */
2923   gfc_start_scalarized_body (&loop, &body);
2924
2925   gfc_conv_tmp_array_ref (&lse);
2926   if (cm->ts.type == BT_CHARACTER)
2927     lse.string_length = cm->ts.cl->backend_decl;
2928
2929   gfc_conv_expr (&rse, expr);
2930
2931   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2932   gfc_add_expr_to_block (&body, tmp);
2933
2934   gcc_assert (rse.ss == gfc_ss_terminator);
2935
2936   /* Generate the copying loops.  */
2937   gfc_trans_scalarizing_loops (&loop, &body);
2938
2939   /* Wrap the whole thing up.  */
2940   gfc_add_block_to_block (&block, &loop.pre);
2941   gfc_add_block_to_block (&block, &loop.post);
2942
2943   for (n = 0; n < cm->as->rank; n++)
2944     mpz_clear (lss->shape[n]);
2945   gfc_free (lss->shape);
2946
2947   gfc_cleanup_loop (&loop);
2948
2949   return gfc_finish_block (&block);
2950 }
2951
2952
2953 /* Assign a single component of a derived type constructor.  */
2954
2955 static tree
2956 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2957 {
2958   gfc_se se;
2959   gfc_se lse;
2960   gfc_ss *rss;
2961   stmtblock_t block;
2962   tree tmp;
2963   tree offset;
2964   int n;
2965
2966   gfc_start_block (&block);
2967
2968   if (cm->pointer)
2969     {
2970       gfc_init_se (&se, NULL);
2971       /* Pointer component.  */
2972       if (cm->dimension)
2973         {
2974           /* Array pointer.  */
2975           if (expr->expr_type == EXPR_NULL)
2976             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2977           else
2978             {
2979               rss = gfc_walk_expr (expr);
2980               se.direct_byref = 1;
2981               se.expr = dest;
2982               gfc_conv_expr_descriptor (&se, expr, rss);
2983               gfc_add_block_to_block (&block, &se.pre);
2984               gfc_add_block_to_block (&block, &se.post);
2985             }
2986         }
2987       else
2988         {
2989           /* Scalar pointers.  */
2990           se.want_pointer = 1;
2991           gfc_conv_expr (&se, expr);
2992           gfc_add_block_to_block (&block, &se.pre);
2993           gfc_add_modify_expr (&block, dest,
2994                                fold_convert (TREE_TYPE (dest), se.expr));
2995           gfc_add_block_to_block (&block, &se.post);
2996         }
2997     }
2998   else if (cm->dimension)
2999     {
3000       if (cm->allocatable && expr->expr_type == EXPR_NULL)
3001         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3002       else if (cm->allocatable)
3003         {
3004           tree tmp2;
3005
3006           gfc_init_se (&se, NULL);
3007  
3008           rss = gfc_walk_expr (expr);
3009           se.want_pointer = 0;
3010           gfc_conv_expr_descriptor (&se, expr, rss);
3011           gfc_add_block_to_block (&block, &se.pre);
3012
3013           tmp = fold_convert (TREE_TYPE (dest), se.expr);
3014           gfc_add_modify_expr (&block, dest, tmp);
3015
3016           if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3017             tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3018                                        cm->as->rank);
3019           else
3020             tmp = gfc_duplicate_allocatable (dest, se.expr,
3021                                              TREE_TYPE(cm->backend_decl),
3022                                              cm->as->rank);
3023
3024           gfc_add_expr_to_block (&block, tmp);
3025
3026           gfc_add_block_to_block (&block, &se.post);
3027           gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3028
3029           /* Shift the lbound and ubound of temporaries to being unity, rather
3030              than zero, based.  Calculate the offset for all cases.  */
3031           offset = gfc_conv_descriptor_offset (dest);
3032           gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3033           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3034           for (n = 0; n < expr->rank; n++)
3035             {
3036               if (expr->expr_type != EXPR_VARIABLE
3037                     && expr->expr_type != EXPR_CONSTANT)
3038                 {
3039                   tree span;
3040                   tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3041                   span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3042                             gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3043                   gfc_add_modify_expr (&block, tmp,
3044                                        fold_build2 (PLUS_EXPR,
3045                                                     gfc_array_index_type,
3046                                                     span, gfc_index_one_node));
3047                   tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3048                   gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3049                 }
3050               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3051                                  gfc_conv_descriptor_lbound (dest,
3052                                                              gfc_rank_cst[n]),
3053                                  gfc_conv_descriptor_stride (dest,
3054                                                              gfc_rank_cst[n]));
3055               gfc_add_modify_expr (&block, tmp2, tmp);
3056               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3057               gfc_add_modify_expr (&block, offset, tmp);
3058             }
3059         }
3060       else
3061         {
3062           tmp = gfc_trans_subarray_assign (dest, cm, expr);
3063           gfc_add_expr_to_block (&block, tmp);
3064         }
3065     }
3066   else if (expr->ts.type == BT_DERIVED)
3067     {
3068       if (expr->expr_type != EXPR_STRUCTURE)
3069         {
3070           gfc_init_se (&se, NULL);
3071           gfc_conv_expr (&se, expr);
3072           gfc_add_modify_expr (&block, dest,
3073                                fold_convert (TREE_TYPE (dest), se.expr));
3074         }
3075       else
3076         {
3077           /* Nested constructors.  */
3078           tmp = gfc_trans_structure_assign (dest, expr);
3079           gfc_add_expr_to_block (&block, tmp);
3080         }
3081     }
3082   else
3083     {
3084       /* Scalar component.  */
3085       gfc_init_se (&se, NULL);
3086       gfc_init_se (&lse, NULL);
3087
3088       gfc_conv_expr (&se, expr);
3089       if (cm->ts.type == BT_CHARACTER)
3090         lse.string_length = cm->ts.cl->backend_decl;
3091       lse.expr = dest;
3092       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3093       gfc_add_expr_to_block (&block, tmp);
3094     }
3095   return gfc_finish_block (&block);
3096 }
3097
3098 /* Assign a derived type constructor to a variable.  */
3099
3100 static tree
3101 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3102 {
3103   gfc_constructor *c;
3104   gfc_component *cm;
3105   stmtblock_t block;
3106   tree field;
3107   tree tmp;
3108
3109   gfc_start_block (&block);
3110   cm = expr->ts.derived->components;
3111   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3112     {
3113       /* Skip absent members in default initializers.  */
3114       if (!c->expr)
3115         continue;
3116
3117       field = cm->backend_decl;
3118       tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3119       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3120       gfc_add_expr_to_block (&block, tmp);
3121     }
3122   return gfc_finish_block (&block);
3123 }
3124
3125 /* Build an expression for a constructor. If init is nonzero then
3126    this is part of a static variable initializer.  */
3127
3128 void
3129 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3130 {
3131   gfc_constructor *c;
3132   gfc_component *cm;
3133   tree val;
3134   tree type;
3135   tree tmp;
3136   VEC(constructor_elt,gc) *v = NULL;
3137
3138   gcc_assert (se->ss == NULL);
3139   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3140   type = gfc_typenode_for_spec (&expr->ts);
3141
3142   if (!init)
3143     {
3144       /* Create a temporary variable and fill it in.  */
3145       se->expr = gfc_create_var (type, expr->ts.derived->name);
3146       tmp = gfc_trans_structure_assign (se->expr, expr);
3147       gfc_add_expr_to_block (&se->pre, tmp);
3148       return;
3149     }
3150
3151   cm = expr->ts.derived->components;
3152
3153   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3154     {
3155       /* Skip absent members in default initializers and allocatable
3156          components.  Although the latter have a default initializer
3157          of EXPR_NULL,... by default, the static nullify is not needed
3158          since this is done every time we come into scope.  */
3159       if (!c->expr || cm->allocatable)
3160         continue;
3161
3162       val = gfc_conv_initializer (c->expr, &cm->ts,
3163           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3164
3165       /* Append it to the constructor list.  */
3166       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3167     }
3168   se->expr = build_constructor (type, v);
3169 }
3170
3171
3172 /* Translate a substring expression.  */
3173
3174 static void
3175 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3176 {
3177   gfc_ref *ref;
3178
3179   ref = expr->ref;
3180
3181   gcc_assert (ref->type == REF_SUBSTRING);
3182
3183   se->expr = gfc_build_string_const(expr->value.character.length,
3184                                     expr->value.character.string);
3185   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3186   TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3187
3188   gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3189 }
3190
3191
3192 /* Entry point for expression translation.  Evaluates a scalar quantity.
3193    EXPR is the expression to be translated, and SE is the state structure if
3194    called from within the scalarized.  */
3195
3196 void
3197 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3198 {
3199   if (se->ss && se->ss->expr == expr
3200       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3201     {
3202       /* Substitute a scalar expression evaluated outside the scalarization
3203          loop.  */
3204       se->expr = se->ss->data.scalar.expr;
3205       se->string_length = se->ss->string_length;
3206       gfc_advance_se_ss_chain (se);
3207       return;
3208     }
3209
3210   /* We need to convert the expressions for the iso_c_binding derived types.
3211      C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3212      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
3213      typespec for the C_PTR and C_FUNPTR symbols, which has already been
3214      updated to be an integer with a kind equal to the size of a (void *).  */
3215   if (expr->ts.type == BT_DERIVED && expr->ts.derived
3216       && expr->ts.derived->attr.is_iso_c)
3217     {
3218       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3219           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3220         {
3221           /* Set expr_type to EXPR_NULL, which will result in
3222              null_pointer_node being used below.  */
3223           expr->expr_type = EXPR_NULL;
3224         }
3225       else
3226         {
3227           /* Update the type/kind of the expression to be what the new
3228              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
3229           expr->ts.type = expr->ts.derived->ts.type;
3230           expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3231           expr->ts.kind = expr->ts.derived->ts.kind;
3232         }
3233     }
3234   
3235   switch (expr->expr_type)
3236     {
3237     case EXPR_OP:
3238       gfc_conv_expr_op (se, expr);
3239       break;
3240
3241     case EXPR_FUNCTION:
3242       gfc_conv_function_expr (se, expr);
3243       break;
3244
3245     case EXPR_CONSTANT:
3246       gfc_conv_constant (se, expr);
3247       break;
3248
3249     case EXPR_VARIABLE:
3250       gfc_conv_variable (se, expr);
3251       break;
3252
3253     case EXPR_NULL:
3254       se->expr = null_pointer_node;
3255       break;
3256
3257     case EXPR_SUBSTRING:
3258       gfc_conv_substring_expr (se, expr);
3259       break;
3260
3261     case EXPR_STRUCTURE:
3262       gfc_conv_structure (se, expr, 0);
3263       break;
3264
3265     case EXPR_ARRAY:
3266       gfc_conv_array_constructor_expr (se, expr);
3267       break;
3268
3269     default:
3270       gcc_unreachable ();
3271       break;
3272     }
3273 }
3274
3275 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3276    of an assignment.  */
3277 void
3278 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3279 {
3280   gfc_conv_expr (se, expr);
3281   /* All numeric lvalues should have empty post chains.  If not we need to
3282      figure out a way of rewriting an lvalue so that it has no post chain.  */
3283   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3284 }
3285
3286 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3287    numeric expressions.  Used for scalar values where inserting cleanup code
3288    is inconvenient.  */
3289 void
3290 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3291 {
3292   tree val;
3293
3294   gcc_assert (expr->ts.type != BT_CHARACTER);
3295   gfc_conv_expr (se, expr);
3296   if (se->post.head)
3297     {
3298       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3299       gfc_add_modify_expr (&se->pre, val, se->expr);
3300       se->expr = val;
3301       gfc_add_block_to_block (&se->pre, &se->post);
3302     }
3303 }
3304
3305 /* Helper to translate and expression and convert it to a particular type.  */
3306 void
3307 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3308 {
3309   gfc_conv_expr_val (se, expr);
3310   se->expr = convert (type, se->expr);
3311 }
3312
3313
3314 /* Converts an expression so that it can be passed by reference.  Scalar
3315    values only.  */
3316
3317 void
3318 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3319 {
3320   tree var;
3321
3322   if (se->ss && se->ss->expr == expr
3323       && se->ss->type == GFC_SS_REFERENCE)
3324     {
3325       se->expr = se->ss->data.scalar.expr;
3326       se->string_length = se->ss->string_length;
3327       gfc_advance_se_ss_chain (se);
3328       return;
3329     }
3330
3331   if (expr->ts.type == BT_CHARACTER)
3332     {
3333       gfc_conv_expr (se, expr);
3334       gfc_conv_string_parameter (se);
3335       return;
3336     }
3337
3338   if (expr->expr_type == EXPR_VARIABLE)
3339     {
3340       se->want_pointer = 1;
3341       gfc_conv_expr (se, expr);
3342       if (se->post.head)
3343         {
3344           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3345           gfc_add_modify_expr (&se->pre, var, se->expr);
3346           gfc_add_block_to_block (&se->pre, &se->post);
3347           se->expr = var;
3348         }
3349       return;
3350     }
3351
3352   gfc_conv_expr (se, expr);
3353
3354   /* Create a temporary var to hold the value.  */
3355   if (TREE_CONSTANT (se->expr))
3356     {
3357       tree tmp = se->expr;
3358       STRIP_TYPE_NOPS (tmp);
3359       var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3360       DECL_INITIAL (var) = tmp;
3361       TREE_STATIC (var) = 1;
3362       pushdecl (var);
3363     }
3364   else
3365     {
3366       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3367       gfc_add_modify_expr (&se->pre, var, se->expr);
3368     }
3369   gfc_add_block_to_block (&se->pre, &se->post);
3370
3371   /* Take the address of that value.  */
3372   se->expr = build_fold_addr_expr (var);
3373 }
3374
3375
3376 tree
3377 gfc_trans_pointer_assign (gfc_code * code)
3378 {
3379   return gfc_trans_pointer_assignment (code->expr, code->expr2);
3380 }
3381
3382
3383 /* Generate code for a pointer assignment.  */
3384
3385 tree
3386 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3387 {
3388   gfc_se lse;
3389   gfc_se rse;
3390   gfc_ss *lss;
3391   gfc_ss *rss;
3392   stmtblock_t block;
3393   tree desc;
3394   tree tmp;
3395
3396   gfc_start_block (&block);
3397
3398   gfc_init_se (&lse, NULL);
3399
3400   lss = gfc_walk_expr (expr1);
3401   rss = gfc_walk_expr (expr2);
3402   if (lss == gfc_ss_terminator)
3403     {
3404       /* Scalar pointers.  */
3405       lse.want_pointer = 1;
3406       gfc_conv_expr (&lse, expr1);
3407       gcc_assert (rss == gfc_ss_terminator);
3408       gfc_init_se (&rse, NULL);
3409       rse.want_pointer = 1;
3410       gfc_conv_expr (&rse, expr2);
3411       gfc_add_block_to_block (&block, &lse.pre);
3412       gfc_add_block_to_block (&block, &rse.pre);
3413       gfc_add_modify_expr (&block, lse.expr,
3414                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3415       gfc_add_block_to_block (&block, &rse.post);
3416       gfc_add_block_to_block (&block, &lse.post);
3417     }
3418   else
3419     {
3420       /* Array pointer.  */
3421       gfc_conv_expr_descriptor (&lse, expr1, lss);
3422       switch (expr2->expr_type)
3423         {
3424         case EXPR_NULL:
3425           /* Just set the data pointer to null.  */
3426           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3427           break;
3428
3429         case EXPR_VARIABLE:
3430           /* Assign directly to the pointer's descriptor.  */
3431           lse.direct_byref = 1;
3432           gfc_conv_expr_descriptor (&lse, expr2, rss);
3433           break;
3434
3435         default:
3436           /* Assign to a temporary descriptor and then copy that
3437              temporary to the pointer.  */
3438           desc = lse.expr;
3439           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3440
3441           lse.expr = tmp;
3442           lse.direct_byref = 1;
3443           gfc_conv_expr_descriptor (&lse, expr2, rss);
3444           gfc_add_modify_expr (&lse.pre, desc, tmp);
3445           break;
3446         }
3447       gfc_add_block_to_block (&block, &lse.pre);
3448       gfc_add_block_to_block (&block, &lse.post);
3449     }
3450   return gfc_finish_block (&block);
3451 }
3452
3453
3454 /* Makes sure se is suitable for passing as a function string parameter.  */
3455 /* TODO: Need to check all callers fo this function.  It may be abused.  */
3456
3457 void
3458 gfc_conv_string_parameter (gfc_se * se)
3459 {
3460   tree type;
3461
3462   if (TREE_CODE (se->expr) == STRING_CST)
3463     {
3464       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3465     &n