OSDN Git Service

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