gcc/fortran/trans-expr.c

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