OSDN Git Service

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