OSDN Git Service

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