OSDN Git Service

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