OSDN Git Service

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