OSDN Git Service

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