OSDN Git Service

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