OSDN Git Service

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