OSDN Git Service

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