OSDN Git Service

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