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,
2298                            int g77, sym_intent intent)
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   stmtblock_t body;
2312   int n;
2313
2314   gcc_assert (expr->expr_type == EXPR_VARIABLE);
2315
2316   gfc_init_se (&lse, NULL);
2317   gfc_init_se (&rse, NULL);
2318
2319   /* Walk the argument expression.  */
2320   rss = gfc_walk_expr (expr);
2321
2322   gcc_assert (rss != gfc_ss_terminator);
2323
2324   /* Initialize the scalarizer.  */
2325   gfc_init_loopinfo (&loop);
2326   gfc_add_ss_to_loop (&loop, rss);
2327
2328   /* Calculate the bounds of the scalarization.  */
2329   gfc_conv_ss_startstride (&loop);
2330
2331   /* Build an ss for the temporary.  */
2332   if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
2333     gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2334
2335   base_type = gfc_typenode_for_spec (&expr->ts);
2336   if (GFC_ARRAY_TYPE_P (base_type)
2337                 || GFC_DESCRIPTOR_TYPE_P (base_type))
2338     base_type = gfc_get_element_type (base_type);
2339
2340   loop.temp_ss = gfc_get_ss ();;
2341   loop.temp_ss->type = GFC_SS_TEMP;
2342   loop.temp_ss->data.temp.type = base_type;
2343
2344   if (expr->ts.type == BT_CHARACTER)
2345     loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2346   else
2347     loop.temp_ss->string_length = NULL;
2348
2349   parmse->string_length = loop.temp_ss->string_length;
2350   loop.temp_ss->data.temp.dimen = loop.dimen;
2351   loop.temp_ss->next = gfc_ss_terminator;
2352
2353   /* Associate the SS with the loop.  */
2354   gfc_add_ss_to_loop (&loop, loop.temp_ss);
2355
2356   /* Setup the scalarizing loops.  */
2357   gfc_conv_loop_setup (&loop, &expr->where);
2358
2359   /* Pass the temporary descriptor back to the caller.  */
2360   info = &loop.temp_ss->data.info;
2361   parmse->expr = info->descriptor;
2362
2363   /* Setup the gfc_se structures.  */
2364   gfc_copy_loopinfo_to_se (&lse, &loop);
2365   gfc_copy_loopinfo_to_se (&rse, &loop);
2366
2367   rse.ss = rss;
2368   lse.ss = loop.temp_ss;
2369   gfc_mark_ss_chain_used (rss, 1);
2370   gfc_mark_ss_chain_used (loop.temp_ss, 1);
2371
2372   /* Start the scalarized loop body.  */
2373   gfc_start_scalarized_body (&loop, &body);
2374
2375   /* Translate the expression.  */
2376   gfc_conv_expr (&rse, expr);
2377
2378   gfc_conv_tmp_array_ref (&lse);
2379   gfc_advance_se_ss_chain (&lse);
2380
2381   if (intent != INTENT_OUT)
2382     {
2383       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2384       gfc_add_expr_to_block (&body, tmp);
2385       gcc_assert (rse.ss == gfc_ss_terminator);
2386       gfc_trans_scalarizing_loops (&loop, &body);
2387     }
2388   else
2389     {
2390       /* Make sure that the temporary declaration survives by merging
2391        all the loop declarations into the current context.  */
2392       for (n = 0; n < loop.dimen; n++)
2393         {
2394           gfc_merge_block_scope (&body);
2395           body = loop.code[loop.order[n]];
2396         }
2397       gfc_merge_block_scope (&body);
2398     }
2399
2400   /* Add the post block after the second loop, so that any
2401      freeing of allocated memory is done at the right time.  */
2402   gfc_add_block_to_block (&parmse->pre, &loop.pre);
2403
2404   /**********Copy the temporary back again.*********/
2405
2406   gfc_init_se (&lse, NULL);
2407   gfc_init_se (&rse, NULL);
2408
2409   /* Walk the argument expression.  */
2410   lss = gfc_walk_expr (expr);
2411   rse.ss = loop.temp_ss;
2412   lse.ss = lss;
2413
2414   /* Initialize the scalarizer.  */
2415   gfc_init_loopinfo (&loop2);
2416   gfc_add_ss_to_loop (&loop2, lss);
2417
2418   /* Calculate the bounds of the scalarization.  */
2419   gfc_conv_ss_startstride (&loop2);
2420
2421   /* Setup the scalarizing loops.  */
2422   gfc_conv_loop_setup (&loop2, &expr->where);
2423
2424   gfc_copy_loopinfo_to_se (&lse, &loop2);
2425   gfc_copy_loopinfo_to_se (&rse, &loop2);
2426
2427   gfc_mark_ss_chain_used (lss, 1);
2428   gfc_mark_ss_chain_used (loop.temp_ss, 1);
2429
2430   /* Declare the variable to hold the temporary offset and start the
2431      scalarized loop body.  */
2432   offset = gfc_create_var (gfc_array_index_type, NULL);
2433   gfc_start_scalarized_body (&loop2, &body);
2434
2435   /* Build the offsets for the temporary from the loop variables.  The
2436      temporary array has lbounds of zero and strides of one in all
2437      dimensions, so this is very simple.  The offset is only computed
2438      outside the innermost loop, so the overall transfer could be
2439      optimized further.  */
2440   info = &rse.ss->data.info;
2441
2442   tmp_index = gfc_index_zero_node;
2443   for (n = info->dimen - 1; n > 0; n--)
2444     {
2445       tree tmp_str;
2446       tmp = rse.loop->loopvar[n];
2447       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2448                          tmp, rse.loop->from[n]);
2449       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2450                          tmp, tmp_index);
2451
2452       tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2453                              rse.loop->to[n-1], rse.loop->from[n-1]);
2454       tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2455                              tmp_str, gfc_index_one_node);
2456
2457       tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2458                                tmp, tmp_str);
2459     }
2460
2461   tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2462                            tmp_index, rse.loop->from[0]);
2463   gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2464
2465   tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2466                            rse.loop->loopvar[0], offset);
2467
2468   /* Now use the offset for the reference.  */
2469   tmp = build_fold_indirect_ref_loc (input_location,
2470                                  info->data);
2471   rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2472
2473   if (expr->ts.type == BT_CHARACTER)
2474     rse.string_length = expr->ts.u.cl->backend_decl;
2475
2476   gfc_conv_expr (&lse, expr);
2477
2478   gcc_assert (lse.ss == gfc_ss_terminator);
2479
2480   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2481   gfc_add_expr_to_block (&body, tmp);
2482
2483   /* Generate the copying loops.  */
2484   gfc_trans_scalarizing_loops (&loop2, &body);
2485
2486   /* Wrap the whole thing up by adding the second loop to the post-block
2487      and following it by the post-block of the first loop.  In this way,
2488      if the temporary needs freeing, it is done after use!  */
2489   if (intent != INTENT_IN)
2490     {
2491       gfc_add_block_to_block (&parmse->post, &loop2.pre);
2492       gfc_add_block_to_block (&parmse->post, &loop2.post);
2493     }
2494
2495   gfc_add_block_to_block (&parmse->post, &loop.post);
2496
2497   gfc_cleanup_loop (&loop);
2498   gfc_cleanup_loop (&loop2);
2499
2500   /* Pass the string length to the argument expression.  */
2501   if (expr->ts.type == BT_CHARACTER)
2502     parmse->string_length = expr->ts.u.cl->backend_decl;
2503
2504   /* We want either the address for the data or the address of the descriptor,
2505      depending on the mode of passing array arguments.  */
2506   if (g77)
2507     parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2508   else
2509     parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2510
2511   return;
2512 }
2513
2514
2515 /* Generate the code for argument list functions.  */
2516
2517 static void
2518 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2519 {
2520   /* Pass by value for g77 %VAL(arg), pass the address
2521      indirectly for %LOC, else by reference.  Thus %REF
2522      is a "do-nothing" and %LOC is the same as an F95
2523      pointer.  */
2524   if (strncmp (name, "%VAL", 4) == 0)
2525     gfc_conv_expr (se, expr);
2526   else if (strncmp (name, "%LOC", 4) == 0)
2527     {
2528       gfc_conv_expr_reference (se, expr);
2529       se->expr = gfc_build_addr_expr (NULL, se->expr);
2530     }
2531   else if (strncmp (name, "%REF", 4) == 0)
2532     gfc_conv_expr_reference (se, expr);
2533   else
2534     gfc_error ("Unknown argument list function at %L", &expr->where);
2535 }
2536
2537
2538 /* Takes a derived type expression and returns the address of a temporary
2539    class object of the 'declared' type.  */
2540 static void
2541 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
2542                            gfc_typespec class_ts)
2543 {
2544   gfc_component *cmp;
2545   gfc_symbol *vtab;
2546   gfc_symbol *declared = class_ts.u.derived;
2547   gfc_ss *ss;
2548   tree ctree;
2549   tree var;
2550   tree tmp;
2551
2552   /* The derived type needs to be converted to a temporary
2553      CLASS object.  */
2554   tmp = gfc_typenode_for_spec (&class_ts);
2555   var = gfc_create_var (tmp, "class");
2556
2557   /* Set the vptr.  */
2558   cmp = gfc_find_component (declared, "$vptr", true, true);
2559   ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2560                        var, cmp->backend_decl, NULL_TREE);
2561
2562   /* Remember the vtab corresponds to the derived type
2563     not to the class declared type.  */
2564   vtab = gfc_find_derived_vtab (e->ts.u.derived);
2565   gcc_assert (vtab);
2566   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
2567   gfc_add_modify (&parmse->pre, ctree,
2568                   fold_convert (TREE_TYPE (ctree), tmp));
2569
2570   /* Now set the data field.  */
2571   cmp = gfc_find_component (declared, "$data", true, true);
2572   ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
2573                        var, cmp->backend_decl, NULL_TREE);
2574   ss = gfc_walk_expr (e);
2575   if (ss == gfc_ss_terminator)
2576     {
2577       gfc_conv_expr_reference (parmse, e);
2578       tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
2579       gfc_add_modify (&parmse->pre, ctree, tmp);
2580     }
2581   else
2582     {
2583       gfc_conv_expr (parmse, e);
2584       gfc_add_modify (&parmse->pre, ctree, parmse->expr);
2585     }
2586
2587   /* Pass the address of the class object.  */
2588   parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
2589 }
2590
2591
2592 /* The following routine generates code for the intrinsic
2593    procedures from the ISO_C_BINDING module:
2594     * C_LOC           (function)
2595     * C_FUNLOC        (function)
2596     * C_F_POINTER     (subroutine)
2597     * C_F_PROCPOINTER (subroutine)
2598     * C_ASSOCIATED    (function)
2599    One exception which is not handled here is C_F_POINTER with non-scalar
2600    arguments. Returns 1 if the call was replaced by inline code (else: 0).  */
2601
2602 static int
2603 conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
2604                             gfc_actual_arglist * arg)
2605 {
2606   gfc_symbol *fsym;
2607   gfc_ss *argss;
2608
2609   if (sym->intmod_sym_id == ISOCBINDING_LOC)
2610     {
2611       if (arg->expr->rank == 0)
2612         gfc_conv_expr_reference (se, arg->expr);
2613       else
2614         {
2615           int f;
2616           /* This is really the actual arg because no formal arglist is
2617              created for C_LOC.  */
2618           fsym = arg->expr->symtree->n.sym;
2619
2620           /* We should want it to do g77 calling convention.  */
2621           f = (fsym != NULL)
2622             && !(fsym->attr.pointer || fsym->attr.allocatable)
2623             && fsym->as->type != AS_ASSUMED_SHAPE;
2624           f = f || !sym->attr.always_explicit;
2625
2626           argss = gfc_walk_expr (arg->expr);
2627           gfc_conv_array_parameter (se, arg->expr, argss, f,
2628                                     NULL, NULL, NULL);
2629         }
2630
2631       /* TODO -- the following two lines shouldn't be necessary, but if
2632          they're removed, a bug is exposed later in the code path.
2633          This workaround was thus introduced, but will have to be
2634          removed; please see PR 35150 for details about the issue.  */
2635       se->expr = convert (pvoid_type_node, se->expr);
2636       se->expr = gfc_evaluate_now (se->expr, &se->pre);
2637
2638       return 1;
2639     }
2640   else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2641     {
2642       arg->expr->ts.type = sym->ts.u.derived->ts.type;
2643       arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
2644       arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
2645       gfc_conv_expr_reference (se, arg->expr);
2646
2647       return 1;
2648     }
2649   else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2650             && arg->next->expr->rank == 0)
2651            || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2652     {
2653       /* Convert c_f_pointer if fptr is a scalar
2654          and convert c_f_procpointer.  */
2655       gfc_se cptrse;
2656       gfc_se fptrse;
2657
2658       gfc_init_se (&cptrse, NULL);
2659       gfc_conv_expr (&cptrse, arg->expr);
2660       gfc_add_block_to_block (&se->pre, &cptrse.pre);
2661       gfc_add_block_to_block (&se->post, &cptrse.post);
2662
2663       gfc_init_se (&fptrse, NULL);
2664       if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
2665           || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
2666         fptrse.want_pointer = 1;
2667
2668       gfc_conv_expr (&fptrse, arg->next->expr);
2669       gfc_add_block_to_block (&se->pre, &fptrse.pre);
2670       gfc_add_block_to_block (&se->post, &fptrse.post);
2671
2672       if (arg->next->expr->symtree->n.sym->attr.proc_pointer
2673           && arg->next->expr->symtree->n.sym->attr.dummy)
2674         fptrse.expr = build_fold_indirect_ref_loc (input_location,
2675                                                    fptrse.expr);
2676
2677       se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
2678                               fptrse.expr,
2679                               fold_convert (TREE_TYPE (fptrse.expr),
2680                                             cptrse.expr));
2681
2682       return 1;
2683     }
2684   else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2685     {
2686       gfc_se arg1se;
2687       gfc_se arg2se;
2688
2689       /* Build the addr_expr for the first argument.  The argument is
2690          already an *address* so we don't need to set want_pointer in
2691          the gfc_se.  */
2692       gfc_init_se (&arg1se, NULL);
2693       gfc_conv_expr (&arg1se, arg->expr);
2694       gfc_add_block_to_block (&se->pre, &arg1se.pre);
2695       gfc_add_block_to_block (&se->post, &arg1se.post);
2696
2697       /* See if we were given two arguments.  */
2698       if (arg->next == NULL)
2699         /* Only given one arg so generate a null and do a
2700            not-equal comparison against the first arg.  */
2701         se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2702                                 fold_convert (TREE_TYPE (arg1se.expr),
2703                                               null_pointer_node));
2704       else
2705         {
2706           tree eq_expr;
2707           tree not_null_expr;
2708
2709           /* Given two arguments so build the arg2se from second arg.  */
2710           gfc_init_se (&arg2se, NULL);
2711           gfc_conv_expr (&arg2se, arg->next->expr);
2712           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2713           gfc_add_block_to_block (&se->post, &arg2se.post);
2714
2715           /* Generate test to compare that the two args are equal.  */
2716           eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2717                                  arg1se.expr, arg2se.expr);
2718           /* Generate test to ensure that the first arg is not null.  */
2719           not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2720                                        arg1se.expr, null_pointer_node);
2721
2722           /* Finally, the generated test must check that both arg1 is not
2723              NULL and that it is equal to the second arg.  */
2724           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2725                                   not_null_expr, eq_expr);
2726         }
2727
2728       return 1;
2729     }
2730
2731   /* Nothing was done.  */
2732   return 0;
2733 }
2734
2735
2736 /* Generate code for a procedure call.  Note can return se->post != NULL.
2737    If se->direct_byref is set then se->expr contains the return parameter.
2738    Return nonzero, if the call has alternate specifiers.
2739    'expr' is only needed for procedure pointer components.  */
2740
2741 int
2742 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2743                          gfc_actual_arglist * arg, gfc_expr * expr,
2744                          tree append_args)
2745 {
2746   gfc_interface_mapping mapping;
2747   tree arglist;
2748   tree retargs;
2749   tree tmp;
2750   tree fntype;
2751   gfc_se parmse;
2752   gfc_ss *argss;
2753   gfc_ss_info *info;
2754   int byref;
2755   int parm_kind;
2756   tree type;
2757   tree var;
2758   tree len;
2759   tree stringargs;
2760   gfc_formal_arglist *formal;
2761   int has_alternate_specifier = 0;
2762   bool need_interface_mapping;
2763   bool callee_alloc;
2764   gfc_typespec ts;
2765   gfc_charlen cl;
2766   gfc_expr *e;
2767   gfc_symbol *fsym;
2768   stmtblock_t post;
2769   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2770   gfc_component *comp = NULL;
2771
2772   arglist = NULL_TREE;
2773   retargs = NULL_TREE;
2774   stringargs = NULL_TREE;
2775   var = NULL_TREE;
2776   len = NULL_TREE;
2777   gfc_clear_ts (&ts);
2778
2779   if (sym->from_intmod == INTMOD_ISO_C_BINDING
2780       && conv_isocbinding_procedure (se, sym, arg))
2781     return 0;
2782
2783   gfc_is_proc_ptr_comp (expr, &comp);
2784
2785   if (se->ss != NULL)
2786     {
2787       if (!sym->attr.elemental)
2788         {
2789           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2790           if (se->ss->useflags)
2791             {
2792               gcc_assert ((!comp && gfc_return_by_reference (sym)
2793                            && sym->result->attr.dimension)
2794                           || (comp && comp->attr.dimension));
2795               gcc_assert (se->loop != NULL);
2796
2797               /* Access the previously obtained result.  */
2798               gfc_conv_tmp_array_ref (se);
2799               gfc_advance_se_ss_chain (se);
2800               return 0;
2801             }
2802         }
2803       info = &se->ss->data.info;
2804     }
2805   else
2806     info = NULL;
2807
2808   gfc_init_block (&post);
2809   gfc_init_interface_mapping (&mapping);
2810   if (!comp)
2811     {
2812       formal = sym->formal;
2813       need_interface_mapping = sym->attr.dimension ||
2814                                (sym->ts.type == BT_CHARACTER
2815                                 && sym->ts.u.cl->length
2816                                 && sym->ts.u.cl->length->expr_type
2817                                    != EXPR_CONSTANT);
2818     }
2819   else
2820     {
2821       formal = comp->formal;
2822       need_interface_mapping = comp->attr.dimension ||
2823                                (comp->ts.type == BT_CHARACTER
2824                                 && comp->ts.u.cl->length
2825                                 && comp->ts.u.cl->length->expr_type
2826                                    != EXPR_CONSTANT);
2827     }
2828
2829   /* Evaluate the arguments.  */
2830   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2831     {
2832       e = arg->expr;
2833       fsym = formal ? formal->sym : NULL;
2834       parm_kind = MISSING;
2835       if (e == NULL)
2836         {
2837
2838           if (se->ignore_optional)
2839             {
2840               /* Some intrinsics have already been resolved to the correct
2841                  parameters.  */
2842               continue;
2843             }
2844           else if (arg->label)
2845             {
2846               has_alternate_specifier = 1;
2847               continue;
2848             }
2849           else
2850             {
2851               /* Pass a NULL pointer for an absent arg.  */
2852               gfc_init_se (&parmse, NULL);
2853               parmse.expr = null_pointer_node;
2854               if (arg->missing_arg_type == BT_CHARACTER)
2855                 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2856             }
2857         }
2858       else if (fsym && fsym->ts.type == BT_CLASS
2859                  && e->ts.type == BT_DERIVED)
2860         {
2861           /* The derived type needs to be converted to a temporary
2862              CLASS object.  */
2863           gfc_init_se (&parmse, se);
2864           gfc_conv_derived_to_class (&parmse, e, fsym->ts);
2865         }
2866       else if (se->ss && se->ss->useflags)
2867         {
2868           /* An elemental function inside a scalarized loop.  */
2869           gfc_init_se (&parmse, se);
2870           gfc_conv_expr_reference (&parmse, e);
2871           parm_kind = ELEMENTAL;
2872         }
2873       else
2874         {
2875           /* A scalar or transformational function.  */
2876           gfc_init_se (&parmse, NULL);
2877           argss = gfc_walk_expr (e);
2878
2879           if (argss == gfc_ss_terminator)
2880             {
2881               if (e->expr_type == EXPR_VARIABLE
2882                     && e->symtree->n.sym->attr.cray_pointee
2883                     && fsym && fsym->attr.flavor == FL_PROCEDURE)
2884                 {
2885                     /* The Cray pointer needs to be converted to a pointer to
2886                        a type given by the expression.  */
2887                     gfc_conv_expr (&parmse, e);
2888                     type = build_pointer_type (TREE_TYPE (parmse.expr));
2889                     tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2890                     parmse.expr = convert (type, tmp);
2891                 }
2892               else if (fsym && fsym->attr.value)
2893                 {
2894                   if (fsym->ts.type == BT_CHARACTER
2895                       && fsym->ts.is_c_interop
2896                       && fsym->ns->proc_name != NULL
2897                       && fsym->ns->proc_name->attr.is_bind_c)
2898                     {
2899                       parmse.expr = NULL;
2900                       gfc_conv_scalar_char_value (fsym, &parmse, &e);
2901                       if (parmse.expr == NULL)
2902                         gfc_conv_expr (&parmse, e);
2903                     }
2904                   else
2905                     gfc_conv_expr (&parmse, e);
2906                 }
2907               else if (arg->name && arg->name[0] == '%')
2908                 /* Argument list functions %VAL, %LOC and %REF are signalled
2909                    through arg->name.  */
2910                 conv_arglist_function (&parmse, arg->expr, arg->name);
2911               else if ((e->expr_type == EXPR_FUNCTION)
2912                         && ((e->value.function.esym
2913                              && e->value.function.esym->result->attr.pointer)
2914                             || (!e->value.function.esym
2915                                 && e->symtree->n.sym->attr.pointer))
2916                         && fsym && fsym->attr.target)
2917                 {
2918                   gfc_conv_expr (&parmse, e);
2919                   parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2920                 }
2921               else if (e->expr_type == EXPR_FUNCTION
2922                        && e->symtree->n.sym->result
2923                        && e->symtree->n.sym->result != e->symtree->n.sym
2924                        && e->symtree->n.sym->result->attr.proc_pointer)
2925                 {
2926                   /* Functions returning procedure pointers.  */
2927                   gfc_conv_expr (&parmse, e);
2928                   if (fsym && fsym->attr.proc_pointer)
2929                     parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2930                 }
2931               else
2932                 {
2933                   gfc_conv_expr_reference (&parmse, e);
2934
2935                   /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2936                      allocated on entry, it must be deallocated.  */
2937                   if (fsym && fsym->attr.allocatable
2938                       && fsym->attr.intent == INTENT_OUT)
2939                     {
2940                       stmtblock_t block;
2941
2942                       gfc_init_block  (&block);
2943                       tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
2944                                                         true, NULL);
2945                       gfc_add_expr_to_block (&block, tmp);
2946                       tmp = fold_build2 (MODIFY_EXPR, void_type_node,
2947                                          parmse.expr, null_pointer_node);
2948                       gfc_add_expr_to_block (&block, tmp);
2949
2950                       if (fsym->attr.optional
2951                           && e->expr_type == EXPR_VARIABLE
2952                           && e->symtree->n.sym->attr.optional)
2953                         {
2954                           tmp = fold_build3 (COND_EXPR, void_type_node,
2955                                      gfc_conv_expr_present (e->symtree->n.sym),
2956                                             gfc_finish_block (&block),
2957                                             build_empty_stmt (input_location));
2958                         }
2959                       else
2960                         tmp = gfc_finish_block (&block);
2961
2962                       gfc_add_expr_to_block (&se->pre, tmp);
2963                     }
2964
2965                   if (fsym && e->expr_type != EXPR_NULL
2966                       && ((fsym->attr.pointer
2967                            && fsym->attr.flavor != FL_PROCEDURE)
2968                           || (fsym->attr.proc_pointer
2969                               && !(e->expr_type == EXPR_VARIABLE
2970                               && e->symtree->n.sym->attr.dummy))
2971                           || (e->expr_type == EXPR_VARIABLE
2972                               && gfc_is_proc_ptr_comp (e, NULL))
2973                           || fsym->attr.allocatable))
2974                     {
2975                       /* Scalar pointer dummy args require an extra level of
2976                          indirection. The null pointer already contains
2977                          this level of indirection.  */
2978                       parm_kind = SCALAR_POINTER;
2979                       parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2980                     }
2981                 }
2982             }
2983           else
2984             {
2985               /* If the procedure requires an explicit interface, the actual
2986                  argument is passed according to the corresponding formal
2987                  argument.  If the corresponding formal argument is a POINTER,
2988                  ALLOCATABLE or assumed shape, we do not use g77's calling
2989                  convention, and pass the address of the array descriptor
2990                  instead. Otherwise we use g77's calling convention.  */
2991               int f;
2992               f = (fsym != NULL)
2993                   && !(fsym->attr.pointer || fsym->attr.allocatable)
2994                   && fsym->as->type != AS_ASSUMED_SHAPE;
2995               if (comp)
2996                 f = f || !comp->attr.always_explicit;
2997               else
2998                 f = f || !sym->attr.always_explicit;
2999
3000               if (e->expr_type == EXPR_VARIABLE
3001                     && is_subref_array (e))
3002                 /* The actual argument is a component reference to an
3003                    array of derived types.  In this case, the argument
3004                    is converted to a temporary, which is passed and then
3005                    written back after the procedure call.  */
3006                 gfc_conv_subref_array_arg (&parmse, e, f,
3007                         fsym ? fsym->attr.intent : INTENT_INOUT);
3008               else
3009                 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
3010                                           sym->name, NULL);
3011
3012               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3013                  allocated on entry, it must be deallocated.  */
3014               if (fsym && fsym->attr.allocatable
3015                   && fsym->attr.intent == INTENT_OUT)
3016                 {
3017                   tmp = build_fold_indirect_ref_loc (input_location,
3018                                                      parmse.expr);
3019                   tmp = gfc_trans_dealloc_allocated (tmp);
3020                   if (fsym->attr.optional
3021                       && e->expr_type == EXPR_VARIABLE
3022                       && e->symtree->n.sym->attr.optional)
3023                     tmp = fold_build3 (COND_EXPR, void_type_node,
3024                                      gfc_conv_expr_present (e->symtree->n.sym),
3025                                        tmp, build_empty_stmt (input_location));
3026                   gfc_add_expr_to_block (&se->pre, tmp);
3027                 }
3028             }
3029         }
3030
3031       /* The case with fsym->attr.optional is that of a user subroutine
3032          with an interface indicating an optional argument.  When we call
3033          an intrinsic subroutine, however, fsym is NULL, but we might still
3034          have an optional argument, so we proceed to the substitution
3035          just in case.  */
3036       if (e && (fsym == NULL || fsym->attr.optional))
3037         {
3038           /* If an optional argument is itself an optional dummy argument,
3039              check its presence and substitute a null if absent.  This is
3040              only needed when passing an array to an elemental procedure
3041              as then array elements are accessed - or no NULL pointer is
3042              allowed and a "1" or "0" should be passed if not present.
3043              When passing a non-array-descriptor full array to a
3044              non-array-descriptor dummy, no check is needed. For
3045              array-descriptor actual to array-descriptor dummy, see
3046              PR 41911 for why a check has to be inserted.
3047              fsym == NULL is checked as intrinsics required the descriptor
3048              but do not always set fsym.  */
3049           if (e->expr_type == EXPR_VARIABLE
3050               && e->symtree->n.sym->attr.optional
3051               && ((e->rank > 0 && sym->attr.elemental)
3052                   || e->representation.length || e->ts.type == BT_CHARACTER
3053                   || (e->rank > 0
3054                       && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
3055                           || fsym->as->type == AS_DEFERRED))))
3056             gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
3057                                     e->representation.length);
3058         }
3059
3060       if (fsym && e)
3061         {
3062           /* Obtain the character length of an assumed character length
3063              length procedure from the typespec.  */
3064           if (fsym->ts.type == BT_CHARACTER
3065               && parmse.string_length == NULL_TREE
3066               && e->ts.type == BT_PROCEDURE
3067               && e->symtree->n.sym->ts.type == BT_CHARACTER
3068               && e->symtree->n.sym->ts.u.cl->length != NULL
3069               && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3070             {
3071               gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
3072               parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3073             }
3074         }
3075
3076       if (fsym && need_interface_mapping && e)
3077         gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
3078
3079       gfc_add_block_to_block (&se->pre, &parmse.pre);
3080       gfc_add_block_to_block (&post, &parmse.post);
3081
3082       /* Allocated allocatable components of derived types must be
3083          deallocated for non-variable scalars.  Non-variable arrays are
3084          dealt with in trans-array.c(gfc_conv_array_parameter).  */
3085       if (e && e->ts.type == BT_DERIVED
3086             && e->ts.u.derived->attr.alloc_comp
3087             && !(e->symtree && e->symtree->n.sym->attr.pointer)
3088             && (e->expr_type != EXPR_VARIABLE && !e->rank))
3089         {
3090           int parm_rank;
3091           tmp = build_fold_indirect_ref_loc (input_location,
3092                                          parmse.expr);
3093           parm_rank = e->rank;
3094           switch (parm_kind)
3095             {
3096             case (ELEMENTAL):
3097             case (SCALAR):
3098               parm_rank = 0;
3099               break;
3100
3101             case (SCALAR_POINTER):
3102               tmp = build_fold_indirect_ref_loc (input_location,
3103                                              tmp);
3104               break;
3105             }
3106
3107           if (e->expr_type == EXPR_OP
3108                 && e->value.op.op == INTRINSIC_PARENTHESES
3109                 && e->value.op.op1->expr_type == EXPR_VARIABLE)
3110             {
3111               tree local_tmp;
3112               local_tmp = gfc_evaluate_now (tmp, &se->pre);
3113               local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3114               gfc_add_expr_to_block (&se->post, local_tmp);
3115             }
3116
3117           tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3118
3119           gfc_add_expr_to_block (&se->post, tmp);
3120         }
3121
3122       /* Add argument checking of passing an unallocated/NULL actual to
3123          a nonallocatable/nonpointer dummy.  */
3124
3125       if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3126         {
3127           symbol_attribute *attr;
3128           char *msg;
3129           tree cond;
3130
3131           if (e->expr_type == EXPR_VARIABLE)
3132             attr = &e->symtree->n.sym->attr;
3133           else if (e->expr_type == EXPR_FUNCTION)
3134             {
3135               /* For intrinsic functions, the gfc_attr are not available.  */
3136               if (e->symtree->n.sym->attr.generic && e->value.function.isym)
3137                 goto end_pointer_check;
3138
3139               if (e->symtree->n.sym->attr.generic)
3140                 attr = &e->value.function.esym->attr;
3141               else
3142                 attr = &e->symtree->n.sym->result->attr;
3143             }
3144           else
3145             goto end_pointer_check;
3146
3147           if (attr->optional)
3148             {
3149               /* If the actual argument is an optional pointer/allocatable and
3150                  the formal argument takes an nonpointer optional value,
3151                  it is invalid to pass a non-present argument on, even
3152                  though there is no technical reason for this in gfortran.
3153                  See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
3154               tree present, nullptr, type;
3155
3156               if (attr->allocatable
3157                   && (fsym == NULL || !fsym->attr.allocatable))
3158                 asprintf (&msg, "Allocatable actual argument '%s' is not "
3159                           "allocated or not present", e->symtree->n.sym->name);
3160               else if (attr->pointer
3161                        && (fsym == NULL || !fsym->attr.pointer))
3162                 asprintf (&msg, "Pointer actual argument '%s' is not "
3163                           "associated or not present",
3164                           e->symtree->n.sym->name);
3165               else if (attr->proc_pointer
3166                        && (fsym == NULL || !fsym->attr.proc_pointer))
3167                 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3168                           "associated or not present",
3169                           e->symtree->n.sym->name);
3170               else
3171                 goto end_pointer_check;
3172
3173               present = gfc_conv_expr_present (e->symtree->n.sym);
3174               type = TREE_TYPE (present);
3175               present = fold_build2 (EQ_EXPR, boolean_type_node, present,
3176                                      fold_convert (type, null_pointer_node));
3177               type = TREE_TYPE (parmse.expr);
3178               nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3179                                      fold_convert (type, null_pointer_node));
3180               cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
3181                                   present, nullptr);
3182             }
3183           else
3184             {
3185               if (attr->allocatable
3186                   && (fsym == NULL || !fsym->attr.allocatable))
3187                 asprintf (&msg, "Allocatable actual argument '%s' is not "
3188                       "allocated", e->symtree->n.sym->name);
3189               else if (attr->pointer
3190                        && (fsym == NULL || !fsym->attr.pointer))
3191                 asprintf (&msg, "Pointer actual argument '%s' is not "
3192                       "associated", e->symtree->n.sym->name);
3193               else if (attr->proc_pointer
3194                        && (fsym == NULL || !fsym->attr.proc_pointer))
3195                 asprintf (&msg, "Proc-pointer actual argument '%s' is not "
3196                       "associated", e->symtree->n.sym->name);
3197               else
3198                 goto end_pointer_check;
3199
3200
3201               cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
3202                                   fold_convert (TREE_TYPE (parmse.expr),
3203                                                 null_pointer_node));
3204             }
3205
3206           gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
3207                                    msg);
3208           gfc_free (msg);
3209         }
3210       end_pointer_check:
3211
3212
3213       /* Character strings are passed as two parameters, a length and a
3214          pointer - except for Bind(c) which only passes the pointer.  */
3215       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
3216         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
3217
3218       arglist = gfc_chainon_list (arglist, parmse.expr);
3219     }
3220   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
3221
3222   if (comp)
3223     ts = comp->ts;
3224   else
3225    ts = sym->ts;
3226
3227   if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
3228     se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3229   else if (ts.type == BT_CHARACTER)
3230     {
3231       if (ts.u.cl->length == NULL)
3232         {
3233           /* Assumed character length results are not allowed by 5.1.1.5 of the
3234              standard and are trapped in resolve.c; except in the case of SPREAD
3235              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
3236              we take the character length of the first argument for the result.
3237              For dummies, we have to look through the formal argument list for
3238              this function and use the character length found there.*/
3239           if (!sym->attr.dummy)
3240             cl.backend_decl = TREE_VALUE (stringargs);
3241           else
3242             {
3243               formal = sym->ns->proc_name->formal;
3244               for (; formal; formal = formal->next)
3245                 if (strcmp (formal->sym->name, sym->name) == 0)
3246                   cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3247             }
3248         }
3249       else
3250         {
3251           tree tmp;
3252
3253           /* Calculate the length of the returned string.  */
3254           gfc_init_se (&parmse, NULL);
3255           if (need_interface_mapping)
3256             gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3257           else
3258             gfc_conv_expr (&parmse, ts.u.cl->length);
3259           gfc_add_block_to_block (&se->pre, &parmse.pre);
3260           gfc_add_block_to_block (&se->post, &parmse.post);
3261
3262           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3263           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
3264                              build_int_cst (gfc_charlen_type_node, 0));
3265           cl.backend_decl = tmp;
3266         }
3267
3268       /* Set up a charlen structure for it.  */
3269       cl.next = NULL;
3270       cl.length = NULL;
3271       ts.u.cl = &cl;
3272
3273       len = cl.backend_decl;
3274     }
3275
3276   byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3277           || (!comp && gfc_return_by_reference (sym));
3278   if (byref)
3279     {
3280       if (se->direct_byref)
3281         {
3282           /* Sometimes, too much indirection can be applied; e.g. for
3283              function_result = array_valued_recursive_function.  */
3284           if (TREE_TYPE (TREE_TYPE (se->expr))
3285                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
3286                 && GFC_DESCRIPTOR_TYPE_P
3287                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3288             se->expr = build_fold_indirect_ref_loc (input_location,
3289                                                 se->expr);
3290
3291           retargs = gfc_chainon_list (retargs, se->expr);
3292         }
3293       else if (comp && comp->attr.dimension)
3294         {
3295           gcc_assert (se->loop && info);
3296
3297           /* Set the type of the array.  */
3298           tmp = gfc_typenode_for_spec (&comp->ts);
3299           info->dimen = se->loop->dimen;
3300
3301           /* Evaluate the bounds of the result, if known.  */
3302           gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
3303
3304           /* Create a temporary to store the result.  In case the function
3305              returns a pointer, the temporary will be a shallow copy and
3306              mustn't be deallocated.  */
3307           callee_alloc = comp->attr.allocatable || comp->attr.pointer;
3308           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3309                                        NULL_TREE, false, !comp->attr.pointer,
3310                                        callee_alloc, &se->ss->expr->where);
3311
3312           /* Pass the temporary as the first argument.  */
3313           tmp = info->descriptor;
3314           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3315           retargs = gfc_chainon_list (retargs, tmp);
3316         }
3317       else if (!comp && sym->result->attr.dimension)
3318         {
3319           gcc_assert (se->loop && info);
3320
3321           /* Set the type of the array.  */
3322           tmp = gfc_typenode_for_spec (&ts);
3323           info->dimen = se->loop->dimen;
3324
3325           /* Evaluate the bounds of the result, if known.  */
3326           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
3327
3328           /* Create a temporary to store the result.  In case the function
3329              returns a pointer, the temporary will be a shallow copy and
3330              mustn't be deallocated.  */
3331           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
3332           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
3333                                        NULL_TREE, false, !sym->attr.pointer,
3334                                        callee_alloc, &se->ss->expr->where);
3335
3336           /* Pass the temporary as the first argument.  */
3337           tmp = info->descriptor;
3338           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3339           retargs = gfc_chainon_list (retargs, tmp);
3340         }
3341       else if (ts.type == BT_CHARACTER)
3342         {
3343           /* Pass the string length.  */
3344           type = gfc_get_character_type (ts.kind, ts.u.cl);
3345           type = build_pointer_type (type);
3346
3347           /* Return an address to a char[0:len-1]* temporary for
3348              character pointers.  */
3349           if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3350                || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3351             {
3352               var = gfc_create_var (type, "pstr");
3353
3354               if ((!comp && sym->attr.allocatable)
3355                   || (comp && comp->attr.allocatable))
3356                 gfc_add_modify (&se->pre, var,
3357                                 fold_convert (TREE_TYPE (var),
3358                                               null_pointer_node));
3359
3360               /* Provide an address expression for the function arguments.  */
3361               var = gfc_build_addr_expr (NULL_TREE, var);
3362             }
3363           else
3364             var = gfc_conv_string_tmp (se, type, len);
3365
3366           retargs = gfc_chainon_list (retargs, var);
3367         }
3368       else
3369         {
3370           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
3371
3372           type = gfc_get_complex_type (ts.kind);
3373           var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
3374           retargs = gfc_chainon_list (retargs, var);
3375         }
3376
3377       /* Add the string length to the argument list.  */
3378       if (ts.type == BT_CHARACTER)
3379         retargs = gfc_chainon_list (retargs, len);
3380     }
3381   gfc_free_interface_mapping (&mapping);
3382
3383   /* Add the return arguments.  */
3384   arglist = chainon (retargs, arglist);
3385
3386   /* Add the hidden string length parameters to the arguments.  */
3387   arglist = chainon (arglist, stringargs);
3388
3389   /* We may want to append extra arguments here.  This is used e.g. for
3390      calls to libgfortran_matmul_??, which need extra information.  */
3391   if (append_args != NULL_TREE)
3392     arglist = chainon (arglist, append_args);
3393
3394   /* Generate the actual call.  */
3395   conv_function_val (se, sym, expr);
3396
3397   /* If there are alternate return labels, function type should be
3398      integer.  Can't modify the type in place though, since it can be shared
3399      with other functions.  For dummy arguments, the typing is done to
3400      to this result, even if it has to be repeated for each call.  */
3401   if (has_alternate_specifier
3402       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
3403     {
3404       if (!sym->attr.dummy)
3405         {
3406           TREE_TYPE (sym->backend_decl)
3407                 = build_function_type (integer_type_node,
3408                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3409           se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3410         }
3411       else
3412         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3413     }
3414
3415   fntype = TREE_TYPE (TREE_TYPE (se->expr));
3416   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
3417
3418   /* If we have a pointer function, but we don't want a pointer, e.g.
3419      something like
3420         x = f()
3421      where f is pointer valued, we have to dereference the result.  */
3422   if (!se->want_pointer && !byref
3423       && (sym->attr.pointer || sym->attr.allocatable)
3424       && !gfc_is_proc_ptr_comp (expr, NULL))
3425     se->expr = build_fold_indirect_ref_loc (input_location,
3426                                         se->expr);
3427
3428   /* f2c calling conventions require a scalar default real function to
3429      return a double precision result.  Convert this back to default
3430      real.  We only care about the cases that can happen in Fortran 77.
3431   */
3432   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
3433       && sym->ts.kind == gfc_default_real_kind
3434       && !sym->attr.always_explicit)
3435     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
3436
3437   /* A pure function may still have side-effects - it may modify its
3438      parameters.  */
3439   TREE_SIDE_EFFECTS (se->expr) = 1;
3440 #if 0
3441   if (!sym->attr.pure)
3442     TREE_SIDE_EFFECTS (se->expr) = 1;
3443 #endif
3444
3445   if (byref)
3446     {
3447       /* Add the function call to the pre chain.  There is no expression.  */
3448       gfc_add_expr_to_block (&se->pre, se->expr);
3449       se->expr = NULL_TREE;
3450
3451       if (!se->direct_byref)
3452         {
3453           if (sym->attr.dimension || (comp && comp->attr.dimension))
3454             {
3455               if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3456                 {
3457                   /* Check the data pointer hasn't been modified.  This would
3458                      happen in a function returning a pointer.  */
3459                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3460                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
3461                                      tmp, info->data);
3462                   gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3463                                            gfc_msg_fault);
3464                 }
3465               se->expr = info->descriptor;
3466               /* Bundle in the string length.  */
3467               se->string_length = len;
3468             }
3469           else if (ts.type == BT_CHARACTER)
3470             {
3471               /* Dereference for character pointer results.  */
3472               if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
3473                   || (comp && (comp->attr.pointer || comp->attr.allocatable)))
3474                 se->expr = build_fold_indirect_ref_loc (input_location, var);
3475               else
3476                 se->expr = var;
3477
3478               se->string_length = len;
3479             }
3480           else
3481             {
3482               gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3483               se->expr = build_fold_indirect_ref_loc (input_location, var);
3484             }
3485         }
3486     }
3487
3488   /* Follow the function call with the argument post block.  */
3489   if (byref)
3490     gfc_add_block_to_block (&se->pre, &post);
3491   else
3492     gfc_add_block_to_block (&se->post, &post);
3493
3494   return has_alternate_specifier;
3495 }
3496
3497
3498 /* Fill a character string with spaces.  */
3499
3500 static tree
3501 fill_with_spaces (tree start, tree type, tree size)
3502 {
3503   stmtblock_t block, loop;
3504   tree i, el, exit_label, cond, tmp;
3505
3506   /* For a simple char type, we can call memset().  */
3507   if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3508     return build_call_expr_loc (input_location,
3509                             built_in_decls[BUILT_IN_MEMSET], 3, start,
3510                             build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3511                                            lang_hooks.to_target_charset (' ')),
3512                             size);
3513
3514   /* Otherwise, we use a loop:
3515         for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3516           *el = (type) ' ';
3517    */
3518
3519   /* Initialize variables.  */
3520   gfc_init_block (&block);
3521   i = gfc_create_var (sizetype, "i");
3522   gfc_add_modify (&block, i, fold_convert (sizetype, size));
3523   el = gfc_create_var (build_pointer_type (type), "el");
3524   gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3525   exit_label = gfc_build_label_decl (NULL_TREE);
3526   TREE_USED (exit_label) = 1;
3527
3528
3529   /* Loop body.  */
3530   gfc_init_block (&loop);
3531
3532   /* Exit condition.  */
3533   cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3534                       fold_convert (sizetype, integer_zero_node));
3535   tmp = build1_v (GOTO_EXPR, exit_label);
3536   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3537                      build_empty_stmt (input_location));
3538   gfc_add_expr_to_block (&loop, tmp);
3539
3540   /* Assignment.  */
3541   gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3542                        build_int_cst (type,
3543                                       lang_hooks.to_target_charset (' ')));
3544
3545   /* Increment loop variables.  */
3546   gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3547                                               TYPE_SIZE_UNIT (type)));
3548   gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3549                                                TREE_TYPE (el), el,
3550                                                TYPE_SIZE_UNIT (type)));
3551
3552   /* Making the loop... actually loop!  */
3553   tmp = gfc_finish_block (&loop);
3554   tmp = build1_v (LOOP_EXPR, tmp);
3555   gfc_add_expr_to_block (&block, tmp);
3556
3557   /* The exit label.  */
3558   tmp = build1_v (LABEL_EXPR, exit_label);
3559   gfc_add_expr_to_block (&block, tmp);
3560
3561
3562   return gfc_finish_block (&block);
3563 }
3564
3565
3566 /* Generate code to copy a string.  */
3567
3568 void
3569 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3570                        int dkind, tree slength, tree src, int skind)
3571 {
3572   tree tmp, dlen, slen;
3573   tree dsc;
3574   tree ssc;
3575   tree cond;
3576   tree cond2;
3577   tree tmp2;
3578   tree tmp3;
3579   tree tmp4;
3580   tree chartype;
3581   stmtblock_t tempblock;
3582
3583   gcc_assert (dkind == skind);
3584
3585   if (slength != NULL_TREE)
3586     {
3587       slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3588       ssc = string_to_single_character (slen, src, skind);
3589     }
3590   else
3591     {
3592       slen = build_int_cst (size_type_node, 1);
3593       ssc =  src;
3594     }
3595
3596   if (dlength != NULL_TREE)
3597     {
3598       dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3599       dsc = string_to_single_character (slen, dest, dkind);
3600     }
3601   else
3602     {
3603       dlen = build_int_cst (size_type_node, 1);
3604       dsc =  dest;
3605     }
3606
3607   if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3608     ssc = string_to_single_character (slen, src, skind);
3609   if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3610     dsc = string_to_single_character (dlen, dest, dkind);
3611
3612
3613   /* Assign directly if the types are compatible.  */
3614   if (dsc != NULL_TREE && ssc != NULL_TREE
3615       && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3616     {
3617       gfc_add_modify (block, dsc, ssc);
3618       return;
3619     }
3620
3621   /* Do nothing if the destination length is zero.  */
3622   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3623                       build_int_cst (size_type_node, 0));
3624
3625   /* The following code was previously in _gfortran_copy_string:
3626
3627        // The two strings may overlap so we use memmove.
3628        void
3629        copy_string (GFC_INTEGER_4 destlen, char * dest,
3630                     GFC_INTEGER_4 srclen, const char * src)
3631        {
3632          if (srclen >= destlen)
3633            {
3634              // This will truncate if too long.
3635              memmove (dest, src, destlen);
3636            }
3637          else
3638            {
3639              memmove (dest, src, srclen);
3640              // Pad with spaces.
3641              memset (&dest[srclen], ' ', destlen - srclen);
3642            }
3643        }
3644
3645      We're now doing it here for better optimization, but the logic
3646      is the same.  */
3647
3648   /* For non-default character kinds, we have to multiply the string
3649      length by the base type size.  */
3650   chartype = gfc_get_char_type (dkind);
3651   slen = fold_build2 (MULT_EXPR, size_type_node,
3652                       fold_convert (size_type_node, slen),
3653                       fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3654   dlen = fold_build2 (MULT_EXPR, size_type_node,
3655                       fold_convert (size_type_node, dlen),
3656                       fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3657
3658   if (dlength)
3659     dest = fold_convert (pvoid_type_node, dest);
3660   else
3661     dest = gfc_build_addr_expr (pvoid_type_node, dest);
3662
3663   if (slength)
3664     src = fold_convert (pvoid_type_node, src);
3665   else
3666     src = gfc_build_addr_expr (pvoid_type_node, src);
3667
3668   /* Truncate string if source is too long.  */
3669   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3670   tmp2 = build_call_expr_loc (input_location,
3671                           built_in_decls[BUILT_IN_MEMMOVE],
3672                           3, dest, src, dlen);
3673
3674   /* Else copy and pad with spaces.  */
3675   tmp3 = build_call_expr_loc (input_location,
3676                           built_in_decls[BUILT_IN_MEMMOVE],
3677                           3, dest, src, slen);
3678
3679   tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3680                       fold_convert (sizetype, slen));
3681   tmp4 = fill_with_spaces (tmp4, chartype,
3682                            fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3683                                         dlen, slen));
3684
3685   gfc_init_block (&tempblock);
3686   gfc_add_expr_to_block (&tempblock, tmp3);
3687   gfc_add_expr_to_block (&tempblock, tmp4);
3688   tmp3 = gfc_finish_block (&tempblock);
3689
3690   /* The whole copy_string function is there.  */
3691   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3692   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3693                      build_empty_stmt (input_location));
3694   gfc_add_expr_to_block (block, tmp);
3695 }
3696
3697
3698 /* Translate a statement function.
3699    The value of a statement function reference is obtained by evaluating the
3700    expression using the values of the actual arguments for the values of the
3701    corresponding dummy arguments.  */
3702
3703 static void
3704 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3705 {
3706   gfc_symbol *sym;
3707   gfc_symbol *fsym;
3708   gfc_formal_arglist *fargs;
3709   gfc_actual_arglist *args;
3710   gfc_se lse;
3711   gfc_se rse;
3712   gfc_saved_var *saved_vars;
3713   tree *temp_vars;
3714   tree type;
3715   tree tmp;
3716   int n;
3717
3718   sym = expr->symtree->n.sym;
3719   args = expr->value.function.actual;
3720   gfc_init_se (&lse, NULL);
3721   gfc_init_se (&rse, NULL);
3722
3723   n = 0;
3724   for (fargs = sym->formal; fargs; fargs = fargs->next)
3725     n++;
3726   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3727   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3728
3729   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3730     {
3731       /* Each dummy shall be specified, explicitly or implicitly, to be
3732          scalar.  */
3733       gcc_assert (fargs->sym->attr.dimension == 0);
3734       fsym = fargs->sym;
3735
3736       /* Create a temporary to hold the value.  */
3737       type = gfc_typenode_for_spec (&fsym->ts);
3738       temp_vars[n] = gfc_create_var (type, fsym->name);
3739
3740       if (fsym->ts.type == BT_CHARACTER)
3741         {
3742           /* Copy string arguments.  */
3743           tree arglen;
3744
3745           gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
3746                       && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
3747
3748           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3749           tmp = gfc_build_addr_expr (build_pointer_type (type),
3750                                      temp_vars[n]);
3751
3752           gfc_conv_expr (&rse, args->expr);
3753           gfc_conv_string_parameter (&rse);
3754           gfc_add_block_to_block (&se->pre, &lse.pre);
3755           gfc_add_block_to_block (&se->pre, &rse.pre);
3756
3757           gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3758                                  rse.string_length, rse.expr, fsym->ts.kind);
3759           gfc_add_block_to_block (&se->pre, &lse.post);
3760           gfc_add_block_to_block (&se->pre, &rse.post);
3761         }
3762       else
3763         {
3764           /* For everything else, just evaluate the expression.  */
3765           gfc_conv_expr (&lse, args->expr);
3766
3767           gfc_add_block_to_block (&se->pre, &lse.pre);
3768           gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3769           gfc_add_block_to_block (&se->pre, &lse.post);
3770         }
3771
3772       args = args->next;
3773     }
3774
3775   /* Use the temporary variables in place of the real ones.  */
3776   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3777     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3778
3779   gfc_conv_expr (se, sym->value);
3780
3781   if (sym->ts.type == BT_CHARACTER)
3782     {
3783       gfc_conv_const_charlen (sym->ts.u.cl);
3784
3785       /* Force the expression to the correct length.  */
3786       if (!INTEGER_CST_P (se->string_length)
3787           || tree_int_cst_lt (se->string_length,
3788                               sym->ts.u.cl->backend_decl))
3789         {
3790           type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
3791           tmp = gfc_create_var (type, sym->name);
3792           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3793           gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3794                                  sym->ts.kind, se->string_length, se->expr,
3795                                  sym->ts.kind);
3796           se->expr = tmp;
3797         }
3798       se->string_length = sym->ts.u.cl->backend_decl;
3799     }
3800
3801   /* Restore the original variables.  */
3802   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3803     gfc_restore_sym (fargs->sym, &saved_vars[n]);
3804   gfc_free (saved_vars);
3805 }
3806
3807
3808 /* Translate a function expression.  */
3809
3810 static void
3811 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3812 {
3813   gfc_symbol *sym;
3814
3815   if (expr->value.function.isym)
3816     {
3817       gfc_conv_intrinsic_function (se, expr);
3818       return;
3819     }
3820
3821   /* We distinguish statement functions from general functions to improve
3822      runtime performance.  */
3823   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3824     {
3825       gfc_conv_statement_function (se, expr);
3826       return;
3827     }
3828
3829   /* expr.value.function.esym is the resolved (specific) function symbol for
3830      most functions.  However this isn't set for dummy procedures.  */
3831   sym = expr->value.function.esym;
3832   if (!sym)
3833     sym = expr->symtree->n.sym;
3834
3835   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3836                           NULL_TREE);
3837 }
3838
3839
3840 static void
3841 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3842 {
3843   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3844   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3845
3846   gfc_conv_tmp_array_ref (se);
3847   gfc_advance_se_ss_chain (se);
3848 }
3849
3850
3851 /* Build a static initializer.  EXPR is the expression for the initial value.
3852    The other parameters describe the variable of the component being
3853    initialized. EXPR may be null.  */
3854
3855 tree
3856 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3857                       bool array, bool pointer)
3858 {
3859   gfc_se se;
3860
3861   if (!(expr || pointer))
3862     return NULL_TREE;
3863
3864   /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3865      (these are the only two iso_c_binding derived types that can be
3866      used as initialization expressions).  If so, we need to modify
3867      the 'expr' to be that for a (void *).  */
3868   if (expr != NULL && expr->ts.type == BT_DERIVED
3869       && expr->ts.is_iso_c && expr->ts.u.derived)
3870     {
3871       gfc_symbol *derived = expr->ts.u.derived;
3872
3873       expr = gfc_int_expr (0);
3874
3875       /* The derived symbol has already been converted to a (void *).  Use
3876          its kind.  */
3877       expr->ts.f90_type = derived->ts.f90_type;
3878       expr->ts.kind = derived->ts.kind;
3879     }
3880
3881   if (array)
3882     {
3883       /* Arrays need special handling.  */
3884       if (pointer)
3885         return gfc_build_null_descriptor (type);
3886       else
3887         return gfc_conv_array_initializer (type, expr);
3888     }
3889   else if (pointer)
3890     return fold_convert (type, null_pointer_node);
3891   else
3892     {
3893       switch (ts->type)
3894         {
3895         case BT_DERIVED:
3896         case BT_CLASS:
3897           gfc_init_se (&se, NULL);
3898           gfc_conv_structure (&se, expr, 1);
3899           return se.expr;
3900
3901         case BT_CHARACTER:
3902           return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
3903
3904         default:
3905           gfc_init_se (&se, NULL);
3906           gfc_conv_constant (&se, expr);
3907           return se.expr;
3908         }
3909     }
3910 }
3911
3912 static tree
3913 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3914 {
3915   gfc_se rse;
3916   gfc_se lse;
3917   gfc_ss *rss;
3918   gfc_ss *lss;
3919   stmtblock_t body;
3920   stmtblock_t block;
3921   gfc_loopinfo loop;
3922   int n;
3923   tree tmp;
3924
3925   gfc_start_block (&block);
3926
3927   /* Initialize the scalarizer.  */
3928   gfc_init_loopinfo (&loop);
3929
3930   gfc_init_se (&lse, NULL);
3931   gfc_init_se (&rse, NULL);
3932
3933   /* Walk the rhs.  */
3934   rss = gfc_walk_expr (expr);
3935   if (rss == gfc_ss_terminator)
3936     {
3937       /* The rhs is scalar.  Add a ss for the expression.  */
3938       rss = gfc_get_ss ();
3939       rss->next = gfc_ss_terminator;
3940       rss->type = GFC_SS_SCALAR;
3941       rss->expr = expr;
3942     }
3943
3944   /* Create a SS for the destination.  */
3945   lss = gfc_get_ss ();
3946   lss->type = GFC_SS_COMPONENT;
3947   lss->expr = NULL;
3948   lss->shape = gfc_get_shape (cm->as->rank);
3949   lss->next = gfc_ss_terminator;
3950   lss->data.info.dimen = cm->as->rank;
3951   lss->data.info.descriptor = dest;
3952   lss->data.info.data = gfc_conv_array_data (dest);
3953   lss->data.info.offset = gfc_conv_array_offset (dest);
3954   for (n = 0; n < cm->as->rank; n++)
3955     {
3956       lss->data.info.dim[n] = n;
3957       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3958       lss->data.info.stride[n] = gfc_index_one_node;
3959
3960       mpz_init (lss->shape[n]);
3961       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3962                cm->as->lower[n]->value.integer);
3963       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3964     }
3965
3966   /* Associate the SS with the loop.  */
3967   gfc_add_ss_to_loop (&loop, lss);
3968   gfc_add_ss_to_loop (&loop, rss);
3969
3970   /* Calculate the bounds of the scalarization.  */
3971   gfc_conv_ss_startstride (&loop);
3972
3973   /* Setup the scalarizing loops.  */
3974   gfc_conv_loop_setup (&loop, &expr->where);
3975
3976   /* Setup the gfc_se structures.  */
3977   gfc_copy_loopinfo_to_se (&lse, &loop);
3978   gfc_copy_loopinfo_to_se (&rse, &loop);
3979
3980   rse.ss = rss;
3981   gfc_mark_ss_chain_used (rss, 1);
3982   lse.ss = lss;
3983   gfc_mark_ss_chain_used (lss, 1);
3984
3985   /* Start the scalarized loop body.  */
3986   gfc_start_scalarized_body (&loop, &body);
3987
3988   gfc_conv_tmp_array_ref (&lse);
3989   if (cm->ts.type == BT_CHARACTER)
3990     lse.string_length = cm->ts.u.cl->backend_decl;
3991
3992   gfc_conv_expr (&rse, expr);
3993
3994   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3995   gfc_add_expr_to_block (&body, tmp);
3996
3997   gcc_assert (rse.ss == gfc_ss_terminator);
3998
3999   /* Generate the copying loops.  */
4000   gfc_trans_scalarizing_loops (&loop, &body);
4001
4002   /* Wrap the whole thing up.  */
4003   gfc_add_block_to_block (&block, &loop.pre);
4004   gfc_add_block_to_block (&block, &loop.post);
4005
4006   for (n = 0; n < cm->as->rank; n++)
4007     mpz_clear (lss->shape[n]);
4008   gfc_free (lss->shape);
4009
4010   gfc_cleanup_loop (&loop);
4011
4012   return gfc_finish_block (&block);
4013 }
4014
4015
4016 /* Assign a single component of a derived type constructor.  */
4017
4018 static tree
4019 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
4020 {
4021   gfc_se se;
4022   gfc_se lse;
4023   gfc_ss *rss;
4024   stmtblock_t block;
4025   tree tmp;
4026   tree offset;
4027   int n;
4028
4029   gfc_start_block (&block);
4030
4031   if (cm->attr.pointer)
4032     {
4033       gfc_init_se (&se, NULL);
4034       /* Pointer component.  */
4035       if (cm->attr.dimension)
4036         {
4037           /* Array pointer.  */
4038           if (expr->expr_type == EXPR_NULL)
4039             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4040           else
4041             {
4042               rss = gfc_walk_expr (expr);
4043               se.direct_byref = 1;
4044               se.expr = dest;
4045               gfc_conv_expr_descriptor (&se, expr, rss);
4046               gfc_add_block_to_block (&block, &se.pre);
4047               gfc_add_block_to_block (&block, &se.post);
4048             }
4049         }
4050       else
4051         {
4052           /* Scalar pointers.  */
4053           se.want_pointer = 1;
4054           gfc_conv_expr (&se, expr);
4055           gfc_add_block_to_block (&block, &se.pre);
4056           gfc_add_modify (&block, dest,
4057                                fold_convert (TREE_TYPE (dest), se.expr));
4058           gfc_add_block_to_block (&block, &se.post);
4059         }
4060     }
4061   else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
4062     {
4063       /* NULL initialization for CLASS components.  */
4064       tmp = gfc_trans_structure_assign (dest,
4065                                         gfc_default_initializer (&cm->ts));
4066       gfc_add_expr_to_block (&block, tmp);
4067     }
4068   else if (cm->attr.dimension)
4069     {
4070       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4071         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4072       else if (cm->attr.allocatable)
4073         {
4074           tree tmp2;
4075
4076           gfc_init_se (&se, NULL);
4077
4078           rss = gfc_walk_expr (expr);
4079           se.want_pointer = 0;
4080           gfc_conv_expr_descriptor (&se, expr, rss);
4081           gfc_add_block_to_block (&block, &se.pre);
4082           gfc_add_modify (&block, dest, se.expr);
4083
4084           if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
4085             tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
4086                                        cm->as->rank);
4087           else
4088             tmp = gfc_duplicate_allocatable (dest, se.expr,
4089                                              TREE_TYPE(cm->backend_decl),
4090                                              cm->as->rank);
4091
4092           gfc_add_expr_to_block (&block, tmp);
4093           gfc_add_block_to_block (&block, &se.post);
4094
4095           if (expr->expr_type != EXPR_VARIABLE)
4096             gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
4097
4098           /* Shift the lbound and ubound of temporaries to being unity, rather
4099              than zero, based.  Calculate the offset for all cases.  */
4100           offset = gfc_conv_descriptor_offset_get (dest);
4101           gfc_add_modify (&block, offset, gfc_index_zero_node);
4102           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
4103           for (n = 0; n < expr->rank; n++)
4104             {
4105               if (expr->expr_type != EXPR_VARIABLE
4106                     && expr->expr_type != EXPR_CONSTANT)
4107                 {
4108                   tree span;
4109                   tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4110                   span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
4111                             gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
4112                   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4113                                      span, gfc_index_one_node);
4114                   gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
4115                                                   tmp);
4116                   gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
4117                                                   gfc_index_one_node);
4118                 }
4119               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4120                                  gfc_conv_descriptor_lbound_get (dest,
4121                                                              gfc_rank_cst[n]),
4122                                  gfc_conv_descriptor_stride_get (dest,
4123                                                              gfc_rank_cst[n]));
4124               gfc_add_modify (&block, tmp2, tmp);
4125               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
4126               gfc_conv_descriptor_offset_set (&block, dest, tmp);
4127             }
4128
4129           if (expr->expr_type == EXPR_FUNCTION
4130                 && expr->value.function.isym
4131                 && expr->value.function.isym->conversion
4132                 && expr->value.function.actual->expr
4133                 && expr->value.function.actual->expr->expr_type
4134                                                 == EXPR_VARIABLE)
4135             {
4136               /* If a conversion expression has a null data pointer
4137                  argument, nullify the allocatable component.  */
4138               gfc_symbol *s;
4139               tree non_null_expr;
4140               tree null_expr;
4141               s = expr->value.function.actual->expr->symtree->n.sym;
4142               if (s->attr.allocatable || s->attr.pointer)
4143                 {
4144                   non_null_expr = gfc_finish_block (&block);
4145                   gfc_start_block (&block);
4146                   gfc_conv_descriptor_data_set (&block, dest,
4147                                                 null_pointer_node);
4148                   null_expr = gfc_finish_block (&block);
4149                   tmp = gfc_conv_descriptor_data_get (s->backend_decl);
4150                   tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
4151                                 fold_convert (TREE_TYPE (tmp),
4152                                               null_pointer_node));
4153                   return build3_v (COND_EXPR, tmp, null_expr,
4154                                    non_null_expr);
4155                 }
4156             }
4157         }
4158       else
4159         {
4160           tmp = gfc_trans_subarray_assign (dest, cm, expr);
4161           gfc_add_expr_to_block (&block, tmp);
4162         }
4163     }
4164   else if (expr->ts.type == BT_DERIVED)
4165     {
4166       if (expr->expr_type != EXPR_STRUCTURE)
4167         {
4168           gfc_init_se (&se, NULL);
4169           gfc_conv_expr (&se, expr);
4170           gfc_add_block_to_block (&block, &se.pre);
4171           gfc_add_modify (&block, dest,
4172                                fold_convert (TREE_TYPE (dest), se.expr));
4173           gfc_add_block_to_block (&block, &se.post);
4174         }
4175       else
4176         {
4177           /* Nested constructors.  */
4178           tmp = gfc_trans_structure_assign (dest, expr);
4179           gfc_add_expr_to_block (&block, tmp);
4180         }
4181     }
4182   else
4183     {
4184       /* Scalar component.  */
4185       gfc_init_se (&se, NULL);
4186       gfc_init_se (&lse, NULL);
4187
4188       gfc_conv_expr (&se, expr);
4189       if (cm->ts.type == BT_CHARACTER)
4190         lse.string_length = cm->ts.u.cl->backend_decl;
4191       lse.expr = dest;
4192       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
4193       gfc_add_expr_to_block (&block, tmp);
4194     }
4195   return gfc_finish_block (&block);
4196 }
4197
4198 /* Assign a derived type constructor to a variable.  */
4199
4200 static tree
4201 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
4202 {
4203   gfc_constructor *c;
4204   gfc_component *cm;
4205   stmtblock_t block;
4206   tree field;
4207   tree tmp;
4208
4209   gfc_start_block (&block);
4210   cm = expr->ts.u.derived->components;
4211   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4212     {
4213       /* Skip absent members in default initializers.  */
4214       if (!c->expr)
4215         continue;
4216
4217       /* Handle c_null_(fun)ptr.  */
4218       if (c && c->expr && c->expr->ts.is_iso_c)
4219         {
4220           field = cm->backend_decl;
4221           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4222                              dest, field, NULL_TREE);
4223           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
4224                              fold_convert (TREE_TYPE (tmp),
4225                                            null_pointer_node));
4226           gfc_add_expr_to_block (&block, tmp);
4227           continue;
4228         }
4229
4230       field = cm->backend_decl;
4231       tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
4232                          dest, field, NULL_TREE);
4233       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
4234       gfc_add_expr_to_block (&block, tmp);
4235     }
4236   return gfc_finish_block (&block);
4237 }
4238
4239 /* Build an expression for a constructor. If init is nonzero then
4240    this is part of a static variable initializer.  */
4241
4242 void
4243 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
4244 {
4245   gfc_constructor *c;
4246   gfc_component *cm;
4247   tree val;
4248   tree type;
4249   tree tmp;
4250   VEC(constructor_elt,gc) *v = NULL;
4251
4252   gcc_assert (se->ss == NULL);
4253   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
4254   type = gfc_typenode_for_spec (&expr->ts);
4255
4256   if (!init)
4257     {
4258       /* Create a temporary variable and fill it in.  */
4259       se->expr = gfc_create_var (type, expr->ts.u.derived->name);
4260       tmp = gfc_trans_structure_assign (se->expr, expr);
4261       gfc_add_expr_to_block (&se->pre, tmp);
4262       return;
4263     }
4264
4265   cm = expr->ts.u.derived->components;
4266
4267   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
4268     {
4269       /* Skip absent members in default initializers and allocatable
4270          components.  Although the latter have a default initializer
4271          of EXPR_NULL,... by default, the static nullify is not needed
4272          since this is done every time we come into scope.  */
4273       if (!c->expr || cm->attr.allocatable)
4274         continue;
4275
4276       if (cm->ts.type == BT_CLASS)
4277         {
4278           gfc_component *data;
4279           data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
4280           val = gfc_conv_initializer (c->expr, &cm->ts,
4281                                       TREE_TYPE (data->backend_decl),
4282                                       data->attr.dimension,
4283                                       data->attr.pointer);
4284
4285           CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
4286         }
4287       else if (strcmp (cm->name, "$size") == 0)
4288         {
4289           val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
4290           CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4291         }
4292       else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4293                && strcmp (cm->name, "$extends") == 0)
4294         {
4295           gfc_symbol *vtabs;
4296           vtabs = cm->initializer->symtree->n.sym;
4297           val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
4298           CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4299         }
4300       else
4301         {
4302           val = gfc_conv_initializer (c->expr, &cm->ts,
4303               TREE_TYPE (cm->backend_decl), cm->attr.dimension,
4304               cm->attr.pointer || cm->attr.proc_pointer);
4305
4306           /* Append it to the constructor list.  */
4307           CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
4308         }
4309     }
4310   se->expr = build_constructor (type, v);
4311   if (init)
4312     TREE_CONSTANT (se->expr) = 1;
4313 }
4314
4315
4316 /* Translate a substring expression.  */
4317
4318 static void
4319 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
4320 {
4321   gfc_ref *ref;
4322
4323   ref = expr->ref;
4324
4325   gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
4326
4327   se->expr = gfc_build_wide_string_const (expr->ts.kind,
4328                                           expr->value.character.length,
4329                                           expr->value.character.string);
4330
4331   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
4332   TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
4333
4334   if (ref)
4335     gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
4336 }
4337
4338
4339 /* Entry point for expression translation.  Evaluates a scalar quantity.
4340    EXPR is the expression to be translated, and SE is the state structure if
4341    called from within the scalarized.  */
4342
4343 void
4344 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
4345 {
4346   if (se->ss && se->ss->expr == expr
4347       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
4348     {
4349       /* Substitute a scalar expression evaluated outside the scalarization
4350          loop.  */
4351       se->expr = se->ss->data.scalar.expr;
4352       se->string_length = se->ss->string_length;
4353       gfc_advance_se_ss_chain (se);
4354       return;
4355     }
4356
4357   /* We need to convert the expressions for the iso_c_binding derived types.
4358      C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4359      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
4360      typespec for the C_PTR and C_FUNPTR symbols, which has already been
4361      updated to be an integer with a kind equal to the size of a (void *).  */
4362   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
4363       && expr->ts.u.derived->attr.is_iso_c)
4364     {
4365       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
4366           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
4367         {
4368           /* Set expr_type to EXPR_NULL, which will result in
4369              null_pointer_node being used below.  */
4370           expr->expr_type = EXPR_NULL;
4371         }
4372       else
4373         {
4374           /* Update the type/kind of the expression to be what the new
4375              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
4376           expr->ts.type = expr->ts.u.derived->ts.type;
4377           expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
4378           expr->ts.kind = expr->ts.u.derived->ts.kind;
4379         }
4380     }
4381
4382   switch (expr->expr_type)
4383     {
4384     case EXPR_OP:
4385       gfc_conv_expr_op (se, expr);
4386       break;
4387
4388     case EXPR_FUNCTION:
4389       gfc_conv_function_expr (se, expr);
4390       break;
4391
4392     case EXPR_CONSTANT:
4393       gfc_conv_constant (se, expr);
4394       break;
4395
4396     case EXPR_VARIABLE:
4397       gfc_conv_variable (se, expr);
4398       break;
4399
4400     case EXPR_NULL:
4401       se->expr = null_pointer_node;
4402       break;
4403
4404     case EXPR_SUBSTRING:
4405       gfc_conv_substring_expr (se, expr);
4406       break;
4407
4408     case EXPR_STRUCTURE:
4409       gfc_conv_structure (se, expr, 0);
4410       break;
4411
4412     case EXPR_ARRAY:
4413       gfc_conv_array_constructor_expr (se, expr);
4414       break;
4415
4416     default:
4417       gcc_unreachable ();
4418       break;
4419     }
4420 }
4421
4422 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4423    of an assignment.  */
4424 void
4425 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
4426 {
4427   gfc_conv_expr (se, expr);
4428   /* All numeric lvalues should have empty post chains.  If not we need to
4429      figure out a way of rewriting an lvalue so that it has no post chain.  */
4430   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
4431 }
4432
4433 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4434    numeric expressions.  Used for scalar values where inserting cleanup code
4435    is inconvenient.  */
4436 void
4437 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
4438 {
4439   tree val;
4440
4441   gcc_assert (expr->ts.type != BT_CHARACTER);
4442   gfc_conv_expr (se, expr);
4443   if (se->post.head)
4444     {
4445       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4446       gfc_add_modify (&se->pre, val, se->expr);
4447       se->expr = val;
4448       gfc_add_block_to_block (&se->pre, &se->post);
4449     }
4450 }
4451
4452 /* Helper to translate an expression and convert it to a particular type.  */
4453 void
4454 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
4455 {
4456   gfc_conv_expr_val (se, expr);
4457   se->expr = convert (type, se->expr);
4458 }
4459
4460
4461 /* Converts an expression so that it can be passed by reference.  Scalar
4462    values only.  */
4463
4464 void
4465 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
4466 {
4467   tree var;
4468
4469   if (se->ss && se->ss->expr == expr
4470       && se->ss->type == GFC_SS_REFERENCE)
4471     {
4472       se->expr = se->ss->data.scalar.expr;
4473       se->string_length = se->ss->string_length;
4474       gfc_advance_se_ss_chain (se);
4475       return;
4476     }
4477
4478   if (expr->ts.type == BT_CHARACTER)
4479     {
4480       gfc_conv_expr (se, expr);
4481       gfc_conv_string_parameter (se);
4482       return;
4483     }
4484
4485   if (expr->expr_type == EXPR_VARIABLE)
4486     {
4487       se->want_pointer = 1;
4488       gfc_conv_expr (se, expr);
4489       if (se->post.head)
4490         {
4491           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4492           gfc_add_modify (&se->pre, var, se->expr);
4493           gfc_add_block_to_block (&se->pre, &se->post);
4494           se->expr = var;
4495         }
4496       return;
4497     }
4498
4499   if (expr->expr_type == EXPR_FUNCTION
4500       && ((expr->value.function.esym
4501            && expr->value.function.esym->result->attr.pointer
4502            && !expr->value.function.esym->result->attr.dimension)
4503           || (!expr->value.function.esym
4504               && expr->symtree->n.sym->attr.pointer
4505               && !expr->symtree->n.sym->attr.dimension)))
4506     {
4507       se->want_pointer = 1;
4508       gfc_conv_expr (se, expr);
4509       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4510       gfc_add_modify (&se->pre, var, se->expr);
4511       se->expr = var;
4512       return;
4513     }
4514
4515
4516   gfc_conv_expr (se, expr);
4517
4518   /* Create a temporary var to hold the value.  */
4519   if (TREE_CONSTANT (se->expr))
4520     {
4521       tree tmp = se->expr;
4522       STRIP_TYPE_NOPS (tmp);
4523       var = build_decl (input_location,
4524                         CONST_DECL, NULL, TREE_TYPE (tmp));
4525       DECL_INITIAL (var) = tmp;
4526       TREE_STATIC (var) = 1;
4527       pushdecl (var);
4528     }
4529   else
4530     {
4531       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4532       gfc_add_modify (&se->pre, var, se->expr);
4533     }
4534   gfc_add_block_to_block (&se->pre, &se->post);
4535
4536   /* Take the address of that value.  */
4537   se->expr = gfc_build_addr_expr (NULL_TREE, var);
4538 }
4539
4540
4541 tree
4542 gfc_trans_pointer_assign (gfc_code * code)
4543 {
4544   return gfc_trans_pointer_assignment (code->expr1, code->expr2);
4545 }
4546
4547
4548 /* Generate code for a pointer assignment.  */
4549
4550 tree
4551 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4552 {
4553   gfc_se lse;
4554   gfc_se rse;
4555   gfc_ss *lss;
4556   gfc_ss *rss;
4557   stmtblock_t block;
4558   tree desc;
4559   tree tmp;
4560   tree decl;
4561
4562   gfc_start_block (&block);
4563
4564   gfc_init_se (&lse, NULL);
4565
4566   lss = gfc_walk_expr (expr1);
4567   rss = gfc_walk_expr (expr2);
4568   if (lss == gfc_ss_terminator)
4569     {
4570       /* Scalar pointers.  */
4571       lse.want_pointer = 1;
4572       gfc_conv_expr (&lse, expr1);
4573       gcc_assert (rss == gfc_ss_terminator);
4574       gfc_init_se (&rse, NULL);
4575       rse.want_pointer = 1;
4576       gfc_conv_expr (&rse, expr2);
4577
4578       if (expr1->symtree->n.sym->attr.proc_pointer
4579           && expr1->symtree->n.sym->attr.dummy)
4580         lse.expr = build_fold_indirect_ref_loc (input_location,
4581                                             lse.expr);
4582
4583       if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
4584           && expr2->symtree->n.sym->attr.dummy)
4585         rse.expr = build_fold_indirect_ref_loc (input_location,
4586                                             rse.expr);
4587
4588       gfc_add_block_to_block (&block, &lse.pre);
4589       gfc_add_block_to_block (&block, &rse.pre);
4590
4591       /* Check character lengths if character expression.  The test is only
4592          really added if -fbounds-check is enabled.  */
4593       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
4594           && !expr1->symtree->n.sym->attr.proc_pointer
4595           && !gfc_is_proc_ptr_comp (expr1, NULL))
4596         {
4597           gcc_assert (expr2->ts.type == BT_CHARACTER);
4598           gcc_assert (lse.string_length && rse.string_length);
4599           gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4600                                        lse.string_length, rse.string_length,
4601                                        &block);
4602         }
4603
4604       gfc_add_modify (&block, lse.expr,
4605                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
4606
4607       gfc_add_block_to_block (&block, &rse.post);
4608       gfc_add_block_to_block (&block, &lse.post);
4609     }
4610   else
4611     {
4612       tree strlen_lhs;
4613       tree strlen_rhs = NULL_TREE;
4614
4615       /* Array pointer.  */
4616       gfc_conv_expr_descriptor (&lse, expr1, lss);
4617       strlen_lhs = lse.string_length;
4618       switch (expr2->expr_type)
4619         {
4620         case EXPR_NULL:
4621           /* Just set the data pointer to null.  */
4622           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4623           break;
4624
4625         case EXPR_VARIABLE:
4626           /* Assign directly to the pointer's descriptor.  */
4627           lse.direct_byref = 1;
4628           gfc_conv_expr_descriptor (&lse, expr2, rss);
4629           strlen_rhs = lse.string_length;
4630
4631           /* If this is a subreference array pointer assignment, use the rhs
4632              descriptor element size for the lhs span.  */
4633           if (expr1->symtree->n.sym->attr.subref_array_pointer)
4634             {
4635               decl = expr1->symtree->n.sym->backend_decl;
4636               gfc_init_se (&rse, NULL);
4637               rse.descriptor_only = 1;
4638               gfc_conv_expr (&rse, expr2);
4639               tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4640               tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4641               if (!INTEGER_CST_P (tmp))
4642                 gfc_add_block_to_block (&lse.post, &rse.pre);
4643               gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4644             }
4645
4646           break;
4647
4648         default:
4649           /* Assign to a temporary descriptor and then copy that
4650              temporary to the pointer.  */
4651           desc = lse.expr;
4652           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4653
4654           lse.expr = tmp;
4655           lse.direct_byref = 1;
4656           gfc_conv_expr_descriptor (&lse, expr2, rss);
4657           strlen_rhs = lse.string_length;
4658           gfc_add_modify (&lse.pre, desc, tmp);
4659           break;
4660         }
4661
4662       gfc_add_block_to_block (&block, &lse.pre);
4663
4664       /* Check string lengths if applicable.  The check is only really added
4665          to the output code if -fbounds-check is enabled.  */
4666       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4667         {
4668           gcc_assert (expr2->ts.type == BT_CHARACTER);
4669           gcc_assert (strlen_lhs && strlen_rhs);
4670           gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4671                                        strlen_lhs, strlen_rhs, &block);
4672         }
4673
4674       gfc_add_block_to_block (&block, &lse.post);
4675     }
4676   return gfc_finish_block (&block);
4677 }
4678
4679
4680 /* Makes sure se is suitable for passing as a function string parameter.  */
4681 /* TODO: Need to check all callers of this function.  It may be abused.  */
4682
4683 void
4684 gfc_conv_string_parameter (gfc_se * se)
4685 {
4686   tree type;
4687
4688   if (TREE_CODE (se->expr) == STRING_CST)
4689     {
4690       type = TREE_TYPE (TREE_TYPE (se->expr));
4691       se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4692       return;
4693     }
4694
4695   if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4696     {
4697       if (TREE_CODE (se->expr) != INDIRECT_REF)
4698         {
4699           type = TREE_TYPE (se->expr);
4700           se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4701         }
4702       else
4703         {
4704           type = gfc_get_character_type_len (gfc_default_character_kind,
4705                                              se->string_length);
4706           type = build_pointer_type (type);
4707           se->expr = gfc_build_addr_expr (type, se->expr);
4708         }
4709     }
4710
4711   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4712   gcc_assert (se->string_length
4713           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4714 }
4715
4716
4717 /* Generate code for assignment of scalar variables.  Includes character
4718    strings and derived types with allocatable components.  */
4719
4720 tree
4721 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4722                          bool l_is_temp, bool r_is_var)
4723 {
4724   stmtblock_t block;
4725   tree tmp;
4726   tree cond;
4727
4728   gfc_init_block (&block);
4729
4730   if (ts.type == BT_CHARACTER)
4731     {
4732       tree rlen = NULL;
4733       tree llen = NULL;
4734
4735       if (lse->string_length != NULL_TREE)
4736         {
4737           gfc_conv_string_parameter (lse);
4738           gfc_add_block_to_block (&block, &lse->pre);
4739           llen = lse->string_length;
4740         }
4741
4742       if (rse->string_length != NULL_TREE)
4743         {
4744           gcc_assert (rse->string_length != NULL_TREE);
4745           gfc_conv_string_parameter (rse);
4746           gfc_add_block_to_block (&block, &rse->pre);
4747           rlen = rse->string_length;
4748         }
4749
4750       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4751                              rse->expr, ts.kind);
4752     }
4753   else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
4754     {
4755       cond = NULL_TREE;
4756
4757       /* Are the rhs and the lhs the same?  */
4758       if (r_is_var)
4759         {
4760           cond = fold_build2 (EQ_EXPR, boolean_type_node,
4761                               gfc_build_addr_expr (NULL_TREE, lse->expr),
4762                               gfc_build_addr_expr (NULL_TREE, rse->expr));
4763           cond = gfc_evaluate_now (cond, &lse->pre);
4764         }
4765
4766       /* Deallocate the lhs allocated components as long as it is not
4767          the same as the rhs.  This must be done following the assignment
4768          to prevent deallocating data that could be used in the rhs
4769          expression.  */
4770       if (!l_is_temp)
4771         {
4772           tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4773           tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
4774           if (r_is_var)
4775             tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4776                             tmp);
4777           gfc_add_expr_to_block (&lse->post, tmp);
4778         }
4779
4780       gfc_add_block_to_block (&block, &rse->pre);
4781       gfc_add_block_to_block (&block, &lse->pre);
4782
4783       gfc_add_modify (&block, lse->expr,
4784                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
4785
4786       /* Do a deep copy if the rhs is a variable, if it is not the
4787          same as the lhs.  */
4788       if (r_is_var)
4789         {
4790           tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
4791           tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
4792                           tmp);
4793           gfc_add_expr_to_block (&block, tmp);
4794         }
4795     }
4796   else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
4797     {
4798       gfc_add_block_to_block (&block, &lse->pre);
4799       gfc_add_block_to_block (&block, &rse->pre);
4800       tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
4801       gfc_add_modify (&block, lse->expr, tmp);
4802     }
4803   else
4804     {
4805       gfc_add_block_to_block (&block, &lse->pre);
4806       gfc_add_block_to_block (&block, &rse->pre);
4807
4808       gfc_add_modify (&block, lse->expr,
4809                       fold_convert (TREE_TYPE (lse->expr), rse->expr));
4810     }
4811
4812   gfc_add_block_to_block (&block, &lse->post);
4813   gfc_add_block_to_block (&block, &rse->post);
4814
4815   return gfc_finish_block (&block);
4816 }
4817
4818
4819 /* Try to translate array(:) = func (...), where func is a transformational
4820    array function, without using a temporary.  Returns NULL is this isn't the
4821    case.  */
4822
4823 static tree
4824 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4825 {
4826   gfc_se se;
4827   gfc_ss *ss;
4828   gfc_ref * ref;
4829   bool seen_array_ref;
4830   bool c = false;
4831   gfc_component *comp = NULL;
4832
4833   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
4834   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4835     return NULL;
4836
4837   /* Elemental functions don't need a temporary anyway.  */
4838   if (expr2->value.function.esym != NULL
4839       && expr2->value.function.esym->attr.elemental)
4840     return NULL;
4841
4842   /* Fail if rhs is not FULL or a contiguous section.  */
4843   if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
4844     return NULL;
4845
4846   /* Fail if EXPR1 can't be expressed as a descriptor.  */
4847   if (gfc_ref_needs_temporary_p (expr1->ref))
4848     return NULL;
4849
4850   /* Functions returning pointers need temporaries.  */
4851   if (expr2->symtree->n.sym->attr.pointer
4852       || expr2->symtree->n.sym->attr.allocatable)
4853     return NULL;
4854
4855   /* Character array functions need temporaries unless the
4856      character lengths are the same.  */
4857   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4858     {
4859       if (expr1->ts.u.cl->length == NULL
4860             || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4861         return NULL;
4862
4863       if (expr2->ts.u.cl->length == NULL
4864             || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4865         return NULL;
4866
4867       if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
4868                      expr2->ts.u.cl->length->value.integer) != 0)
4869         return NULL;
4870     }
4871
4872   /* Check that no LHS component references appear during an array
4873      reference. This is needed because we do not have the means to
4874      span any arbitrary stride with an array descriptor. This check
4875      is not needed for the rhs because the function result has to be
4876      a complete type.  */
4877   seen_array_ref = false;
4878   for (ref = expr1->ref; ref; ref = ref->next)
4879     {
4880       if (ref->type == REF_ARRAY)
4881         seen_array_ref= true;
4882       else if (ref->type == REF_COMPONENT && seen_array_ref)
4883         return NULL;
4884     }
4885
4886   /* Check for a dependency.  */
4887   if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4888                                    expr2->value.function.esym,
4889                                    expr2->value.function.actual,
4890                                    NOT_ELEMENTAL))
4891     return NULL;
4892
4893   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4894      functions.  */
4895   gcc_assert (expr2->value.function.isym
4896               || (gfc_is_proc_ptr_comp (expr2, &comp)
4897                   && comp && comp->attr.dimension)
4898               || (!comp && gfc_return_by_reference (expr2->value.function.esym)
4899                   && expr2->value.function.esym->result->attr.dimension));
4900
4901   ss = gfc_walk_expr (expr1);
4902   gcc_assert (ss != gfc_ss_terminator);
4903   gfc_init_se (&se, NULL);
4904   gfc_start_block (&se.pre);
4905   se.want_pointer = 1;
4906
4907   gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
4908
4909   se.direct_byref = 1;
4910   se.ss = gfc_walk_expr (expr2);
4911   gcc_assert (se.ss != gfc_ss_terminator);
4912   gfc_conv_function_expr (&se, expr2);
4913   gfc_add_block_to_block (&se.pre, &se.post);
4914
4915   return gfc_finish_block (&se.pre);
4916 }
4917
4918 /* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
4919
4920 static bool
4921 is_zero_initializer_p (gfc_expr * expr)
4922 {
4923   if (expr->expr_type != EXPR_CONSTANT)
4924     return false;
4925
4926   /* We ignore constants with prescribed memory representations for now.  */
4927   if (expr->representation.string)
4928     return false;
4929
4930   switch (expr->ts.type)
4931     {
4932     case BT_INTEGER:
4933       return mpz_cmp_si (expr->value.integer, 0) == 0;
4934
4935     case BT_REAL:
4936       return mpfr_zero_p (expr->value.real)
4937              && MPFR_SIGN (expr->value.real) >= 0;
4938
4939     case BT_LOGICAL:
4940       return expr->value.logical == 0;
4941
4942     case BT_COMPLEX:
4943       return mpfr_zero_p (mpc_realref (expr->value.complex))
4944              && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
4945              && mpfr_zero_p (mpc_imagref (expr->value.complex))
4946              && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
4947
4948     default:
4949       break;
4950     }
4951   return false;
4952 }
4953
4954 /* Try to efficiently translate array(:) = 0.  Return NULL if this
4955    can't be done.  */
4956
4957 static tree
4958 gfc_trans_zero_assign (gfc_expr * expr)
4959 {
4960   tree dest, len, type;
4961   tree tmp;
4962   gfc_symbol *sym;
4963
4964   sym = expr->symtree->n.sym;
4965   dest = gfc_get_symbol_decl (sym);
4966
4967   type = TREE_TYPE (dest);
4968   if (POINTER_TYPE_P (type))
4969     type = TREE_TYPE (type);
4970   if (!GFC_ARRAY_TYPE_P (type))
4971     return NULL_TREE;
4972
4973   /* Determine the length of the array.  */
4974   len = GFC_TYPE_ARRAY_SIZE (type);
4975   if (!len || TREE_CODE (len) != INTEGER_CST)
4976     return NULL_TREE;
4977
4978   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4979   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4980                      fold_convert (gfc_array_index_type, tmp));
4981
4982   /* If we are zeroing a local array avoid taking its address by emitting
4983      a = {} instead.  */
4984   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4985     return build2 (MODIFY_EXPR, void_type_node,
4986                    dest, build_constructor (TREE_TYPE (dest), NULL));
4987
4988   /* Convert arguments to the correct types.  */
4989   dest = fold_convert (pvoid_type_node, dest);
4990   len = fold_convert (size_type_node, len);
4991
4992   /* Construct call to __builtin_memset.  */
4993   tmp = build_call_expr_loc (input_location,
4994                          built_in_decls[BUILT_IN_MEMSET],
4995                          3, dest, integer_zero_node, len);
4996   return fold_convert (void_type_node, tmp);
4997 }
4998
4999
5000 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5001    that constructs the call to __builtin_memcpy.  */
5002
5003 tree
5004 gfc_build_memcpy_call (tree dst, tree src, tree len)
5005 {
5006   tree tmp;
5007
5008   /* Convert arguments to the correct types.  */
5009   if (!POINTER_TYPE_P (TREE_TYPE (dst)))
5010     dst = gfc_build_addr_expr (pvoid_type_node, dst);
5011   else
5012     dst = fold_convert (pvoid_type_node, dst);
5013
5014   if (!POINTER_TYPE_P (TREE_TYPE (src)))
5015     src = gfc_build_addr_expr (pvoid_type_node, src);
5016   else
5017     src = fold_convert (pvoid_type_node, src);
5018
5019   len = fold_convert (size_type_node, len);
5020
5021   /* Construct call to __builtin_memcpy.  */
5022   tmp = build_call_expr_loc (input_location,
5023                          built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
5024   return fold_convert (void_type_node, tmp);
5025 }
5026
5027
5028 /* Try to efficiently translate dst(:) = src(:).  Return NULL if this
5029    can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
5030    source/rhs, both are gfc_full_array_ref_p which have been checked for
5031    dependencies.  */
5032
5033 static tree
5034 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
5035 {
5036   tree dst, dlen, dtype;
5037   tree src, slen, stype;
5038   tree tmp;
5039
5040   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5041   src = gfc_get_symbol_decl (expr2->symtree->n.sym);
5042
5043   dtype = TREE_TYPE (dst);
5044   if (POINTER_TYPE_P (dtype))
5045     dtype = TREE_TYPE (dtype);
5046   stype = TREE_TYPE (src);
5047   if (POINTER_TYPE_P (stype))
5048     stype = TREE_TYPE (stype);
5049
5050   if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
5051     return NULL_TREE;
5052
5053   /* Determine the lengths of the arrays.  */
5054   dlen = GFC_TYPE_ARRAY_SIZE (dtype);
5055   if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
5056     return NULL_TREE;
5057   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5058   dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
5059                       fold_convert (gfc_array_index_type, tmp));
5060
5061   slen = GFC_TYPE_ARRAY_SIZE (stype);
5062   if (!slen || TREE_CODE (slen) != INTEGER_CST)
5063     return NULL_TREE;
5064   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5065   slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
5066                       fold_convert (gfc_array_index_type, tmp));
5067
5068   /* Sanity check that they are the same.  This should always be
5069      the case, as we should already have checked for conformance.  */
5070   if (!tree_int_cst_equal (slen, dlen))
5071     return NULL_TREE;
5072
5073   return gfc_build_memcpy_call (dst, src, dlen);
5074 }
5075
5076
5077 /* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
5078    this can't be done.  EXPR1 is the destination/lhs for which
5079    gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
5080
5081 static tree
5082 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
5083 {
5084   unsigned HOST_WIDE_INT nelem;
5085   tree dst, dtype;
5086   tree src, stype;
5087   tree len;
5088   tree tmp;
5089
5090   nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
5091   if (nelem == 0)
5092     return NULL_TREE;
5093
5094   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
5095   dtype = TREE_TYPE (dst);
5096   if (POINTER_TYPE_P (dtype))
5097     dtype = TREE_TYPE (dtype);
5098   if (!GFC_ARRAY_TYPE_P (dtype))
5099     return NULL_TREE;
5100
5101   /* Determine the lengths of the array.  */
5102   len = GFC_TYPE_ARRAY_SIZE (dtype);
5103   if (!len || TREE_CODE (len) != INTEGER_CST)
5104     return NULL_TREE;
5105
5106   /* Confirm that the constructor is the same size.  */
5107   if (compare_tree_int (len, nelem) != 0)
5108     return NULL_TREE;
5109
5110   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5111   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
5112                      fold_convert (gfc_array_index_type, tmp));
5113
5114   stype = gfc_typenode_for_spec (&expr2->ts);
5115   src = gfc_build_constant_array_constructor (expr2, stype);
5116
5117   stype = TREE_TYPE (src);
5118   if (POINTER_TYPE_P (stype))
5119     stype = TREE_TYPE (stype);
5120
5121   return gfc_build_memcpy_call (dst, src, len);
5122 }
5123
5124
5125 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5126    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.  */
5127
5128 static tree
5129 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5130 {
5131   gfc_se lse;
5132   gfc_se rse;
5133   gfc_ss *lss;
5134   gfc_ss *lss_section;
5135   gfc_ss *rss;
5136   gfc_loopinfo loop;
5137   tree tmp;
5138   stmtblock_t block;
5139   stmtblock_t body;
5140   bool l_is_temp;
5141   bool scalar_to_array;
5142   tree string_length;
5143
5144   /* Assignment of the form lhs = rhs.  */
5145   gfc_start_block (&block);
5146
5147   gfc_init_se (&lse, NULL);
5148   gfc_init_se (&rse, NULL);
5149
5150   /* Walk the lhs.  */
5151   lss = gfc_walk_expr (expr1);
5152   rss = NULL;
5153   if (lss != gfc_ss_terminator)
5154     {
5155       /* Allow the scalarizer to workshare array assignments.  */
5156       if (ompws_flags & OMPWS_WORKSHARE_FLAG)
5157         ompws_flags |= OMPWS_SCALARIZER_WS;
5158
5159       /* The assignment needs scalarization.  */
5160       lss_section = lss;
5161
5162       /* Find a non-scalar SS from the lhs.  */
5163       while (lss_section != gfc_ss_terminator
5164              && lss_section->type != GFC_SS_SECTION)
5165         lss_section = lss_section->next;
5166
5167       gcc_assert (lss_section != gfc_ss_terminator);
5168
5169       /* Initialize the scalarizer.  */
5170       gfc_init_loopinfo (&loop);
5171
5172       /* Walk the rhs.  */
5173       rss = gfc_walk_expr (expr2);
5174       if (rss == gfc_ss_terminator)
5175         {
5176           /* The rhs is scalar.  Add a ss for the expression.  */
5177           rss = gfc_get_ss ();
5178           rss->next = gfc_ss_terminator;
5179           rss->type = GFC_SS_SCALAR;
5180           rss->expr = expr2;
5181         }
5182       /* Associate the SS with the loop.  */
5183       gfc_add_ss_to_loop (&loop, lss);
5184       gfc_add_ss_to_loop (&loop, rss);
5185
5186       /* Calculate the bounds of the scalarization.  */
5187       gfc_conv_ss_startstride (&loop);
5188       /* Resolve any data dependencies in the statement.  */
5189       gfc_conv_resolve_dependencies (&loop, lss, rss);
5190       /* Setup the scalarizing loops.  */
5191       gfc_conv_loop_setup (&loop, &expr2->where);
5192
5193       /* Setup the gfc_se structures.  */
5194       gfc_copy_loopinfo_to_se (&lse, &loop);
5195       gfc_copy_loopinfo_to_se (&rse, &loop);
5196
5197       rse.ss = rss;
5198       gfc_mark_ss_chain_used (rss, 1);
5199       if (loop.temp_ss == NULL)
5200         {
5201           lse.ss = lss;
5202           gfc_mark_ss_chain_used (lss, 1);
5203         }
5204       else
5205         {
5206           lse.ss = loop.temp_ss;
5207           gfc_mark_ss_chain_used (lss, 3);
5208           gfc_mark_ss_chain_used (loop.temp_ss, 3);
5209         }
5210
5211       /* Start the scalarized loop body.  */
5212       gfc_start_scalarized_body (&loop, &body);
5213     }
5214   else
5215     gfc_init_block (&body);
5216
5217   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
5218
5219   /* Translate the expression.  */
5220   gfc_conv_expr (&rse, expr2);
5221
5222   /* Stabilize a string length for temporaries.  */
5223   if (expr2->ts.type == BT_CHARACTER)
5224     string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
5225   else
5226     string_length = NULL_TREE;
5227
5228   if (l_is_temp)
5229     {
5230       gfc_conv_tmp_array_ref (&lse);
5231       gfc_advance_se_ss_chain (&lse);
5232       if (expr2->ts.type == BT_CHARACTER)
5233         lse.string_length = string_length;
5234     }
5235   else
5236     gfc_conv_expr (&lse, expr1);
5237
5238   /* Assignments of scalar derived types with allocatable components
5239      to arrays must be done with a deep copy and the rhs temporary
5240      must have its components deallocated afterwards.  */
5241   scalar_to_array = (expr2->ts.type == BT_DERIVED
5242                        && expr2->ts.u.derived->attr.alloc_comp
5243                        && expr2->expr_type != EXPR_VARIABLE
5244                        && !gfc_is_constant_expr (expr2)
5245                        && expr1->rank && !expr2->rank);
5246   if (scalar_to_array)
5247     {
5248       tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5249       gfc_add_expr_to_block (&loop.post, tmp);
5250     }
5251
5252   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5253                                  l_is_temp || init_flag,
5254                                  (expr2->expr_type == EXPR_VARIABLE)
5255                                     || scalar_to_array);
5256   gfc_add_expr_to_block (&body, tmp);
5257
5258   if (lss == gfc_ss_terminator)
5259     {
5260       /* Use the scalar assignment as is.  */
5261       gfc_add_block_to_block (&block, &body);
5262     }
5263   else
5264     {
5265       gcc_assert (lse.ss == gfc_ss_terminator
5266                   && rse.ss == gfc_ss_terminator);
5267
5268       if (l_is_temp)
5269         {
5270           gfc_trans_scalarized_loop_boundary (&loop, &body);
5271
5272           /* We need to copy the temporary to the actual lhs.  */
5273           gfc_init_se (&lse, NULL);
5274           gfc_init_se (&rse, NULL);
5275           gfc_copy_loopinfo_to_se (&lse, &loop);
5276           gfc_copy_loopinfo_to_se (&rse, &loop);
5277
5278           rse.ss = loop.temp_ss;
5279           lse.ss = lss;
5280
5281           gfc_conv_tmp_array_ref (&rse);
5282           gfc_advance_se_ss_chain (&rse);
5283           gfc_conv_expr (&lse, expr1);
5284
5285           gcc_assert (lse.ss == gfc_ss_terminator
5286                       && rse.ss == gfc_ss_terminator);
5287
5288           if (expr2->ts.type == BT_CHARACTER)
5289             rse.string_length = string_length;
5290
5291           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5292                                          false, false);
5293           gfc_add_expr_to_block (&body, tmp);
5294         }
5295
5296       /* Generate the copying loops.  */
5297       gfc_trans_scalarizing_loops (&loop, &body);
5298
5299       /* Wrap the whole thing up.  */
5300       gfc_add_block_to_block (&block, &loop.pre);
5301       gfc_add_block_to_block (&block, &loop.post);
5302
5303       gfc_cleanup_loop (&loop);
5304     }
5305
5306   return gfc_finish_block (&block);
5307 }
5308
5309
5310 /* Check whether EXPR is a copyable array.  */
5311
5312 static bool
5313 copyable_array_p (gfc_expr * expr)
5314 {
5315   if (expr->expr_type != EXPR_VARIABLE)
5316     return false;
5317
5318   /* First check it's an array.  */
5319   if (expr->rank < 1 || !expr->ref || expr->ref->next)
5320     return false;
5321
5322   if (!gfc_full_array_ref_p (expr->ref, NULL))
5323     return false;
5324
5325   /* Next check that it's of a simple enough type.  */
5326   switch (expr->ts.type)
5327     {
5328     case BT_INTEGER:
5329     case BT_REAL:
5330     case BT_COMPLEX:
5331     case BT_LOGICAL:
5332       return true;
5333
5334     case BT_CHARACTER:
5335       return false;
5336
5337     case BT_DERIVED:
5338       return !expr->ts.u.derived->attr.alloc_comp;
5339
5340     default:
5341       break;
5342     }
5343
5344   return false;
5345 }
5346
5347 /* Translate an assignment.  */
5348
5349 tree
5350 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
5351 {
5352   tree tmp;
5353
5354   /* Special case a single function returning an array.  */
5355   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5356     {
5357       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5358       if (tmp)
5359         return tmp;
5360     }
5361
5362   /* Special case assigning an array to zero.  */
5363   if (copyable_array_p (expr1)
5364       && is_zero_initializer_p (expr2))
5365     {
5366       tmp = gfc_trans_zero_assign (expr1);
5367       if (tmp)
5368         return tmp;
5369     }
5370
5371   /* Special case copying one array to another.  */
5372   if (copyable_array_p (expr1)
5373       && copyable_array_p (expr2)
5374       && gfc_compare_types (&expr1->ts, &expr2->ts)
5375       && !gfc_check_dependency (expr1, expr2, 0))
5376     {
5377       tmp = gfc_trans_array_copy (expr1, expr2);
5378       if (tmp)
5379         return tmp;
5380     }
5381
5382   /* Special case initializing an array from a constant array constructor.  */
5383   if (copyable_array_p (expr1)
5384       && expr2->expr_type == EXPR_ARRAY
5385       && gfc_compare_types (&expr1->ts, &expr2->ts))
5386     {
5387       tmp = gfc_trans_array_constructor_copy (expr1, expr2);
5388       if (tmp)
5389         return tmp;
5390     }
5391
5392   /* Fallback to the scalarizer to generate explicit loops.  */
5393   return gfc_trans_assignment_1 (expr1, expr2, init_flag);
5394 }
5395
5396 tree
5397 gfc_trans_init_assign (gfc_code * code)
5398 {
5399   return gfc_trans_assignment (code->expr1, code->expr2, true);
5400 }
5401
5402 tree
5403 gfc_trans_assign (gfc_code * code)
5404 {
5405   return gfc_trans_assignment (code->expr1, code->expr2, false);
5406 }
5407
5408
5409 /* Translate an assignment to a CLASS object
5410    (pointer or ordinary assignment).  */
5411
5412 tree
5413 gfc_trans_class_assign (gfc_code *code)
5414 {
5415   stmtblock_t block;
5416   tree tmp;
5417   gfc_expr *lhs;
5418   gfc_expr *rhs;
5419
5420   gfc_start_block (&block);
5421
5422   if (code->expr2->ts.type != BT_CLASS)
5423     {
5424       /* Insert an additional assignment which sets the '$vptr' field.  */
5425       lhs = gfc_copy_expr (code->expr1);
5426       gfc_add_component_ref (lhs, "$vptr");
5427       if (code->expr2->ts.type == BT_DERIVED)
5428         {
5429           gfc_symbol *vtab;
5430           gfc_symtree *st;
5431           vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
5432           gcc_assert (vtab);
5433
5434           rhs = gfc_get_expr ();
5435           rhs->expr_type = EXPR_VARIABLE;
5436           gfc_find_sym_tree (vtab->name, NULL, 1, &st);
5437           rhs->symtree = st;
5438           rhs->ts = vtab->ts;
5439         }
5440       else if (code->expr2->expr_type == EXPR_NULL)
5441         rhs = gfc_int_expr (0);
5442       else
5443         gcc_unreachable ();
5444
5445       tmp = gfc_trans_pointer_assignment (lhs, rhs);
5446       gfc_add_expr_to_block (&block, tmp);
5447
5448       gfc_free_expr (lhs);
5449       gfc_free_expr (rhs);
5450     }
5451
5452   /* Do the actual CLASS assignment.  */
5453   if (code->expr2->ts.type == BT_CLASS)
5454     code->op = EXEC_ASSIGN;
5455   else
5456     gfc_add_component_ref (code->expr1, "$data");
5457
5458   if (code->op == EXEC_ASSIGN)
5459     tmp = gfc_trans_assign (code);
5460   else if (code->op == EXEC_POINTER_ASSIGN)
5461     tmp = gfc_trans_pointer_assign (code);
5462   else
5463     gcc_unreachable();
5464
5465   gfc_add_expr_to_block (&block, tmp);
5466
5467   return gfc_finish_block (&block);
5468 }