OSDN Git Service

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