OSDN Git Service

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