OSDN Git Service

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