OSDN Git Service

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