OSDN Git Service

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