gcc/fortran/trans-expr.c

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