OSDN Git Service

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