OSDN Git Service

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