OSDN Git Service

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