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 "gimple.h"
  34 #include "langhooks.h"
  35 #include "flags.h"
  36 #include "gfortran.h"
  37 #include "arith.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  43 #include "trans-stmt.h"
  44 #include "dependency.h"
  45
  46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
  47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
  48                                                  gfc_expr *);
  49
  50 /* Copy the scalarization loop variables.  */
  51
  52 static void
  53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
  54 {
  55   dest->ss = src->ss;
  56   dest->loop = src->loop;
  57 }
  58
  59
  60 /* Initialize a simple expression holder.
  61
  62    Care must be taken when multiple se are created with the same parent.
  63    The child se must be kept in sync.  The easiest way is to delay creation
  64    of a child se until after after the previous se has been translated.  */
  65
  66 void
  67 gfc_init_se (gfc_se * se, gfc_se * parent)
  68 {
  69   memset (se, 0, sizeof (gfc_se));
  70   gfc_init_block (&se->pre);
  71   gfc_init_block (&se->post);
  72
  73   se->parent = parent;
  74
  75   if (parent)
  76     gfc_copy_se_loopvars (se, parent);
  77 }
  78
  79
  80 /* Advances to the next SS in the chain.  Use this rather than setting
  81    se->ss = se->ss->next because all the parents needs to be kept in sync.
  82    See gfc_init_se.  */
  83
  84 void
  85 gfc_advance_se_ss_chain (gfc_se * se)
  86 {
  87   gfc_se *p;
  88
  89   gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
  90
  91   p = se;
  92   /* Walk down the parent chain.  */
  93   while (p != NULL)
  94     {
  95       /* Simple consistency check.  */
  96       gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
  97
  98       p->ss = p->ss->next;
  99
 100       p = p->parent;
 101     }
 102 }
 103
 104
 105 /* Ensures the result of the expression as either a temporary variable
 106    or a constant so that it can be used repeatedly.  */
 107
 108 void
 109 gfc_make_safe_expr (gfc_se * se)
 110 {
 111   tree var;
 112
 113   if (CONSTANT_CLASS_P (se->expr))
 114     return;
 115
 116   /* We need a temporary for this result.  */
 117   var = gfc_create_var (TREE_TYPE (se->expr), NULL);
 118   gfc_add_modify (&se->pre, var, se->expr);
 119   se->expr = var;
 120 }
 121
 122
 123 /* Return an expression which determines if a dummy parameter is present.
 124    Also used for arguments to procedures with multiple entry points.  */
 125
 126 tree
 127 gfc_conv_expr_present (gfc_symbol * sym)
 128 {
 129   tree decl;
 130
 131   gcc_assert (sym->attr.dummy);
 132
 133   decl = gfc_get_symbol_decl (sym);
 134   if (TREE_CODE (decl) != PARM_DECL)
 135     {
 136       /* Array parameters use a temporary descriptor, we want the real
 137          parameter.  */
 138       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 139              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
 140       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
 141     }
 142   return fold_build2 (NE_EXPR, boolean_type_node, decl,
 143                       fold_convert (TREE_TYPE (decl), null_pointer_node));
 144 }
 145
 146
 147 /* Converts a missing, dummy argument into a null or zero.  */
 148
 149 void
 150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
 151 {
 152   tree present;
 153   tree tmp;
 154
 155   present = gfc_conv_expr_present (arg->symtree->n.sym);
 156
 157   if (kind > 0)
 158     {
 159       /* Create a temporary and convert it to the correct type.  */
 160       tmp = gfc_get_int_type (kind);
 161       tmp = fold_convert (tmp, build_fold_indirect_ref (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 (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 (true, false, 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 (true, false, 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 (&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 (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 (&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, NULL, NULL);
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, fsym,
2539                                           sym->name);
2540
2541               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2542                  allocated on entry, it must be deallocated.  */
2543               if (fsym && fsym->attr.allocatable
2544                   && fsym->attr.intent == INTENT_OUT)
2545                 {
2546                   tmp = build_fold_indirect_ref (parmse.expr);
2547                   tmp = gfc_trans_dealloc_allocated (tmp);
2548                   gfc_add_expr_to_block (&se->pre, tmp);
2549                 }
2550
2551             }
2552         }
2553
2554       /* The case with fsym->attr.optional is that of a user subroutine
2555          with an interface indicating an optional argument.  When we call
2556          an intrinsic subroutine, however, fsym is NULL, but we might still
2557          have an optional argument, so we proceed to the substitution
2558          just in case.  */
2559       if (e && (fsym == NULL || fsym->attr.optional))
2560         {
2561           /* If an optional argument is itself an optional dummy argument,
2562              check its presence and substitute a null if absent.  */
2563           if (e->expr_type == EXPR_VARIABLE
2564               && e->symtree->n.sym->attr.optional)
2565             gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2566                                     e->representation.length);
2567         }
2568
2569       if (fsym && e)
2570         {
2571           /* Obtain the character length of an assumed character length
2572              length procedure from the typespec.  */
2573           if (fsym->ts.type == BT_CHARACTER
2574               && parmse.string_length == NULL_TREE
2575               && e->ts.type == BT_PROCEDURE
2576               && e->symtree->n.sym->ts.type == BT_CHARACTER
2577               && e->symtree->n.sym->ts.cl->length != NULL)
2578             {
2579               gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2580               parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2581             }
2582         }
2583
2584       if (fsym && need_interface_mapping && e)
2585         gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2586
2587       gfc_add_block_to_block (&se->pre, &parmse.pre);
2588       gfc_add_block_to_block (&post, &parmse.post);
2589
2590       /* Allocated allocatable components of derived types must be
2591          deallocated for INTENT(OUT) dummy arguments and non-variable
2592          scalars.  Non-variable arrays are dealt with in trans-array.c
2593          (gfc_conv_array_parameter).  */
2594       if (e && e->ts.type == BT_DERIVED
2595             && e->ts.derived->attr.alloc_comp
2596             && ((formal && formal->sym->attr.intent == INTENT_OUT)
2597                    ||
2598                 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2599         {
2600           int parm_rank;
2601           tmp = build_fold_indirect_ref (parmse.expr);
2602           parm_rank = e->rank;
2603           switch (parm_kind)
2604             {
2605             case (ELEMENTAL):
2606             case (SCALAR):
2607               parm_rank = 0;
2608               break;
2609
2610             case (SCALAR_POINTER):
2611               tmp = build_fold_indirect_ref (tmp);
2612               break;
2613             case (ARRAY):
2614               tmp = parmse.expr;
2615               break;
2616             }
2617
2618           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2619           if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2620             tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2621                             tmp, build_empty_stmt ());
2622
2623           if (e->expr_type != EXPR_VARIABLE)
2624             /* Don't deallocate non-variables until they have been used.  */
2625             gfc_add_expr_to_block (&se->post, tmp);
2626           else
2627             {
2628               gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2629               gfc_add_expr_to_block (&se->pre, tmp);
2630             }
2631         }
2632
2633       /* Character strings are passed as two parameters, a length and a
2634          pointer - except for Bind(c) which only passes the pointer.  */
2635       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2636         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2637
2638       arglist = gfc_chainon_list (arglist, parmse.expr);
2639     }
2640   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2641
2642   ts = sym->ts;
2643   if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2644     {
2645       if (sym->ts.cl->length == NULL)
2646         {
2647           /* Assumed character length results are not allowed by 5.1.1.5 of the
2648              standard and are trapped in resolve.c; except in the case of SPREAD
2649              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
2650              we take the character length of the first argument for the result.
2651              For dummies, we have to look through the formal argument list for
2652              this function and use the character length found there.*/
2653           if (!sym->attr.dummy)
2654             cl.backend_decl = TREE_VALUE (stringargs);
2655           else
2656             {
2657               formal = sym->ns->proc_name->formal;
2658               for (; formal; formal = formal->next)
2659                 if (strcmp (formal->sym->name, sym->name) == 0)
2660                   cl.backend_decl = formal->sym->ts.cl->backend_decl;
2661             }
2662         }
2663         else
2664         {
2665           tree tmp;
2666
2667           /* Calculate the length of the returned string.  */
2668           gfc_init_se (&parmse, NULL);
2669           if (need_interface_mapping)
2670             gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2671           else
2672             gfc_conv_expr (&parmse, sym->ts.cl->length);
2673           gfc_add_block_to_block (&se->pre, &parmse.pre);
2674           gfc_add_block_to_block (&se->post, &parmse.post);
2675
2676           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2677           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2678                              build_int_cst (gfc_charlen_type_node, 0));
2679           cl.backend_decl = tmp;
2680         }
2681
2682       /* Set up a charlen structure for it.  */
2683       cl.next = NULL;
2684       cl.length = NULL;
2685       ts.cl = &cl;
2686
2687       len = cl.backend_decl;
2688     }
2689
2690   byref = gfc_return_by_reference (sym);
2691   if (byref)
2692     {
2693       if (se->direct_byref)
2694         {
2695           /* Sometimes, too much indirection can be applied; e.g. for
2696              function_result = array_valued_recursive_function.  */
2697           if (TREE_TYPE (TREE_TYPE (se->expr))
2698                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2699                 && GFC_DESCRIPTOR_TYPE_P
2700                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2701             se->expr = build_fold_indirect_ref (se->expr);
2702
2703           retargs = gfc_chainon_list (retargs, se->expr);
2704         }
2705       else if (sym->result->attr.dimension)
2706         {
2707           gcc_assert (se->loop && info);
2708
2709           /* Set the type of the array.  */
2710           tmp = gfc_typenode_for_spec (&ts);
2711           info->dimen = se->loop->dimen;
2712
2713           /* Evaluate the bounds of the result, if known.  */
2714           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2715
2716           /* Create a temporary to store the result.  In case the function
2717              returns a pointer, the temporary will be a shallow copy and
2718              mustn't be deallocated.  */
2719           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2720           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2721                                        false, !sym->attr.pointer, callee_alloc,
2722                                        &se->ss->expr->where);
2723
2724           /* Pass the temporary as the first argument.  */
2725           tmp = info->descriptor;
2726           tmp = build_fold_addr_expr (tmp);
2727           retargs = gfc_chainon_list (retargs, tmp);
2728         }
2729       else if (ts.type == BT_CHARACTER)
2730         {
2731           /* Pass the string length.  */
2732           type = gfc_get_character_type (ts.kind, ts.cl);
2733           type = build_pointer_type (type);
2734
2735           /* Return an address to a char[0:len-1]* temporary for
2736              character pointers.  */
2737           if (sym->attr.pointer || sym->attr.allocatable)
2738             {
2739               var = gfc_create_var (type, "pstr");
2740
2741               /* Provide an address expression for the function arguments.  */
2742               var = build_fold_addr_expr (var);
2743             }
2744           else
2745             var = gfc_conv_string_tmp (se, type, len);
2746
2747           retargs = gfc_chainon_list (retargs, var);
2748         }
2749       else
2750         {
2751           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2752
2753           type = gfc_get_complex_type (ts.kind);
2754           var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2755           retargs = gfc_chainon_list (retargs, var);
2756         }
2757
2758       /* Add the string length to the argument list.  */
2759       if (ts.type == BT_CHARACTER)
2760         retargs = gfc_chainon_list (retargs, len);
2761     }
2762   gfc_free_interface_mapping (&mapping);
2763
2764   /* Add the return arguments.  */
2765   arglist = chainon (retargs, arglist);
2766
2767   /* Add the hidden string length parameters to the arguments.  */
2768   arglist = chainon (arglist, stringargs);
2769
2770   /* We may want to append extra arguments here.  This is used e.g. for
2771      calls to libgfortran_matmul_??, which need extra information.  */
2772   if (append_args != NULL_TREE)
2773     arglist = chainon (arglist, append_args);
2774
2775   /* Generate the actual call.  */
2776   gfc_conv_function_val (se, sym);
2777
2778   /* If there are alternate return labels, function type should be
2779      integer.  Can't modify the type in place though, since it can be shared
2780      with other functions.  For dummy arguments, the typing is done to
2781      to this result, even if it has to be repeated for each call.  */
2782   if (has_alternate_specifier
2783       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2784     {
2785       if (!sym->attr.dummy)
2786         {
2787           TREE_TYPE (sym->backend_decl)
2788                 = build_function_type (integer_type_node,
2789                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2790           se->expr = build_fold_addr_expr (sym->backend_decl);
2791         }
2792       else
2793         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2794     }
2795
2796   fntype = TREE_TYPE (TREE_TYPE (se->expr));
2797   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2798
2799   /* If we have a pointer function, but we don't want a pointer, e.g.
2800      something like
2801         x = f()
2802      where f is pointer valued, we have to dereference the result.  */
2803   if (!se->want_pointer && !byref && sym->attr.pointer)
2804     se->expr = build_fold_indirect_ref (se->expr);
2805
2806   /* f2c calling conventions require a scalar default real function to
2807      return a double precision result.  Convert this back to default
2808      real.  We only care about the cases that can happen in Fortran 77.
2809   */
2810   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2811       && sym->ts.kind == gfc_default_real_kind
2812       && !sym->attr.always_explicit)
2813     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2814
2815   /* A pure function may still have side-effects - it may modify its
2816      parameters.  */
2817   TREE_SIDE_EFFECTS (se->expr) = 1;
2818 #if 0
2819   if (!sym->attr.pure)
2820     TREE_SIDE_EFFECTS (se->expr) = 1;
2821 #endif
2822
2823   if (byref)
2824     {
2825       /* Add the function call to the pre chain.  There is no expression.  */
2826       gfc_add_expr_to_block (&se->pre, se->expr);
2827       se->expr = NULL_TREE;
2828
2829       if (!se->direct_byref)
2830         {
2831           if (sym->attr.dimension)
2832             {
2833               if (flag_bounds_check)
2834                 {
2835                   /* Check the data pointer hasn't been modified.  This would
2836                      happen in a function returning a pointer.  */
2837                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2838                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
2839                                      tmp, info->data);
2840                   gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
2841                                            gfc_msg_fault);
2842                 }
2843               se->expr = info->descriptor;
2844               /* Bundle in the string length.  */
2845               se->string_length = len;
2846             }
2847           else if (sym->ts.type == BT_CHARACTER)
2848             {
2849               /* Dereference for character pointer results.  */
2850               if (sym->attr.pointer || sym->attr.allocatable)
2851                 se->expr = build_fold_indirect_ref (var);
2852               else
2853                 se->expr = var;
2854
2855               se->string_length = len;
2856             }
2857           else
2858             {
2859               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2860               se->expr = build_fold_indirect_ref (var);
2861             }
2862         }
2863     }
2864
2865   /* Follow the function call with the argument post block.  */
2866   if (byref)
2867     gfc_add_block_to_block (&se->pre, &post);
2868   else
2869     gfc_add_block_to_block (&se->post, &post);
2870
2871   return has_alternate_specifier;
2872 }
2873
2874
2875 /* Fill a character string with spaces.  */
2876
2877 static tree
2878 fill_with_spaces (tree start, tree type, tree size)
2879 {
2880   stmtblock_t block, loop;
2881   tree i, el, exit_label, cond, tmp;
2882
2883   /* For a simple char type, we can call memset().  */
2884   if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
2885     return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
2886                             build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2887                                            lang_hooks.to_target_charset (' ')),
2888                             size);
2889
2890   /* Otherwise, we use a loop:
2891         for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
2892           *el = (type) ' ';
2893    */
2894
2895   /* Initialize variables.  */
2896   gfc_init_block (&block);
2897   i = gfc_create_var (sizetype, "i");
2898   gfc_add_modify (&block, i, fold_convert (sizetype, size));
2899   el = gfc_create_var (build_pointer_type (type), "el");
2900   gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
2901   exit_label = gfc_build_label_decl (NULL_TREE);
2902   TREE_USED (exit_label) = 1;
2903
2904
2905   /* Loop body.  */
2906   gfc_init_block (&loop);
2907
2908   /* Exit condition.  */
2909   cond = fold_build2 (LE_EXPR, boolean_type_node, i,
2910                       fold_convert (sizetype, integer_zero_node));
2911   tmp = build1_v (GOTO_EXPR, exit_label);
2912   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2913   gfc_add_expr_to_block (&loop, tmp);
2914
2915   /* Assignment.  */
2916   gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
2917                        build_int_cst (type,
2918                                       lang_hooks.to_target_charset (' ')));
2919
2920   /* Increment loop variables.  */
2921   gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
2922                                               TYPE_SIZE_UNIT (type)));
2923   gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
2924                                                TREE_TYPE (el), el,
2925                                                TYPE_SIZE_UNIT (type)));
2926
2927   /* Making the loop... actually loop!  */
2928   tmp = gfc_finish_block (&loop);
2929   tmp = build1_v (LOOP_EXPR, tmp);
2930   gfc_add_expr_to_block (&block, tmp);
2931
2932   /* The exit label.  */
2933   tmp = build1_v (LABEL_EXPR, exit_label);
2934   gfc_add_expr_to_block (&block, tmp);
2935
2936
2937   return gfc_finish_block (&block);
2938 }
2939
2940
2941 /* Generate code to copy a string.  */
2942
2943 void
2944 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2945                        int dkind, tree slength, tree src, int skind)
2946 {
2947   tree tmp, dlen, slen;
2948   tree dsc;
2949   tree ssc;
2950   tree cond;
2951   tree cond2;
2952   tree tmp2;
2953   tree tmp3;
2954   tree tmp4;
2955   tree chartype;
2956   stmtblock_t tempblock;
2957
2958   gcc_assert (dkind == skind);
2959
2960   if (slength != NULL_TREE)
2961     {
2962       slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2963       ssc = string_to_single_character (slen, src, skind);
2964     }
2965   else
2966     {
2967       slen = build_int_cst (size_type_node, 1);
2968       ssc =  src;
2969     }
2970
2971   if (dlength != NULL_TREE)
2972     {
2973       dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2974       dsc = string_to_single_character (slen, dest, dkind);
2975     }
2976   else
2977     {
2978       dlen = build_int_cst (size_type_node, 1);
2979       dsc =  dest;
2980     }
2981
2982   if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
2983     ssc = string_to_single_character (slen, src, skind);
2984   if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
2985     dsc = string_to_single_character (dlen, dest, dkind);
2986
2987
2988   /* Assign directly if the types are compatible.  */
2989   if (dsc != NULL_TREE && ssc != NULL_TREE
2990       && TREE_TYPE (dsc) == TREE_TYPE (ssc))
2991     {
2992       gfc_add_modify (block, dsc, ssc);
2993       return;
2994     }
2995
2996   /* Do nothing if the destination length is zero.  */
2997   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2998                       build_int_cst (size_type_node, 0));
2999
3000   /* The following code was previously in _gfortran_copy_string:
3001
3002        // The two strings may overlap so we use memmove.
3003        void
3004        copy_string (GFC_INTEGER_4 destlen, char * dest,
3005                     GFC_INTEGER_4 srclen, const char * src)
3006        {
3007          if (srclen >= destlen)
3008            {
3009              // This will truncate if too long.
3010              memmove (dest, src, destlen);
3011            }
3012          else
3013            {
3014              memmove (dest, src, srclen);
3015              // Pad with spaces.
3016              memset (&dest[srclen], ' ', destlen - srclen);
3017            }
3018        }
3019
3020      We're now doing it here for better optimization, but the logic
3021      is the same.  */
3022
3023   /* For non-default character kinds, we have to multiply the string
3024      length by the base type size.  */
3025   chartype = gfc_get_char_type (dkind);
3026   slen = fold_build2 (MULT_EXPR, size_type_node, slen,
3027                       TYPE_SIZE_UNIT (chartype));
3028   dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
3029                       TYPE_SIZE_UNIT (chartype));
3030
3031   if (dlength)
3032     dest = fold_convert (pvoid_type_node, dest);
3033   else
3034     dest = gfc_build_addr_expr (pvoid_type_node, dest);
3035
3036   if (slength)
3037     src = fold_convert (pvoid_type_node, src);
3038   else
3039     src = gfc_build_addr_expr (pvoid_type_node, src);
3040
3041   /* Truncate string if source is too long.  */
3042   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3043   tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3044                           3, dest, src, dlen);
3045
3046   /* Else copy and pad with spaces.  */
3047   tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3048                           3, dest, src, slen);
3049
3050   tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3051                       fold_convert (sizetype, slen));
3052   tmp4 = fill_with_spaces (tmp4, chartype,
3053                            fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3054                                         dlen, slen));
3055
3056   gfc_init_block (&tempblock);
3057   gfc_add_expr_to_block (&tempblock, tmp3);
3058   gfc_add_expr_to_block (&tempblock, tmp4);
3059   tmp3 = gfc_finish_block (&tempblock);
3060
3061   /* The whole copy_string function is there.  */
3062   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3063   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3064   gfc_add_expr_to_block (block, tmp);
3065 }
3066
3067
3068 /* Translate a statement function.
3069    The value of a statement function reference is obtained by evaluating the
3070    expression using the values of the actual arguments for the values of the
3071    corresponding dummy arguments.  */
3072
3073 static void
3074 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3075 {
3076   gfc_symbol *sym;
3077   gfc_symbol *fsym;
3078   gfc_formal_arglist *fargs;
3079   gfc_actual_arglist *args;
3080   gfc_se lse;
3081   gfc_se rse;
3082   gfc_saved_var *saved_vars;
3083   tree *temp_vars;
3084   tree type;
3085   tree tmp;
3086   int n;
3087
3088   sym = expr->symtree->n.sym;
3089   args = expr->value.function.actual;
3090   gfc_init_se (&lse, NULL);
3091   gfc_init_se (&rse, NULL);
3092
3093   n = 0;
3094   for (fargs = sym->formal; fargs; fargs = fargs->next)
3095     n++;
3096   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3097   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3098
3099   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3100     {
3101       /* Each dummy shall be specified, explicitly or implicitly, to be
3102          scalar.  */
3103       gcc_assert (fargs->sym->attr.dimension == 0);
3104       fsym = fargs->sym;
3105
3106       /* Create a temporary to hold the value.  */
3107       type = gfc_typenode_for_spec (&fsym->ts);
3108       temp_vars[n] = gfc_create_var (type, fsym->name);
3109
3110       if (fsym->ts.type == BT_CHARACTER)
3111         {
3112           /* Copy string arguments.  */
3113           tree arglen;
3114
3115           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3116                       && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3117
3118           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3119           tmp = gfc_build_addr_expr (build_pointer_type (type),
3120                                      temp_vars[n]);
3121
3122           gfc_conv_expr (&rse, args->expr);
3123           gfc_conv_string_parameter (&rse);
3124           gfc_add_block_to_block (&se->pre, &lse.pre);
3125           gfc_add_block_to_block (&se->pre, &rse.pre);
3126
3127           gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3128                                  rse.string_length, rse.expr, fsym->ts.kind);
3129           gfc_add_block_to_block (&se->pre, &lse.post);
3130           gfc_add_block_to_block (&se->pre, &rse.post);
3131         }
3132       else
3133         {
3134           /* For everything else, just evaluate the expression.  */
3135           gfc_conv_expr (&lse, args->expr);
3136
3137           gfc_add_block_to_block (&se->pre, &lse.pre);
3138           gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3139           gfc_add_block_to_block (&se->pre, &lse.post);
3140         }
3141
3142       args = args->next;
3143     }
3144
3145   /* Use the temporary variables in place of the real ones.  */
3146   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3147     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3148
3149   gfc_conv_expr (se, sym->value);
3150
3151   if (sym->ts.type == BT_CHARACTER)
3152     {
3153       gfc_conv_const_charlen (sym->ts.cl);
3154
3155       /* Force the expression to the correct length.  */
3156       if (!INTEGER_CST_P (se->string_length)
3157           || tree_int_cst_lt (se->string_length,
3158                               sym->ts.cl->backend_decl))
3159         {
3160           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3161           tmp = gfc_create_var (type, sym->name);
3162           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3163           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3164                                  sym->ts.kind, se->string_length, se->expr,
3165                                  sym->ts.kind);
3166           se->expr = tmp;
3167         }
3168       se->string_length = sym->ts.cl->backend_decl;
3169     }
3170
3171   /* Restore the original variables.  */
3172   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3173     gfc_restore_sym (fargs->sym, &saved_vars[n]);
3174   gfc_free (saved_vars);
3175 }
3176
3177
3178 /* Translate a function expression.  */
3179
3180 static void
3181 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3182 {
3183   gfc_symbol *sym;
3184
3185   if (expr->value.function.isym)
3186     {
3187       gfc_conv_intrinsic_function (se, expr);
3188       return;
3189     }
3190
3191   /* We distinguish statement functions from general functions to improve
3192      runtime performance.  */
3193   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3194     {
3195       gfc_conv_statement_function (se, expr);
3196       return;
3197     }
3198
3199   /* expr.value.function.esym is the resolved (specific) function symbol for
3200      most functions.  However this isn't set for dummy procedures.  */
3201   sym = expr->value.function.esym;
3202   if (!sym)
3203     sym = expr->symtree->n.sym;
3204   gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3205 }
3206
3207
3208 static void
3209 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3210 {
3211   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3212   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3213
3214   gfc_conv_tmp_array_ref (se);
3215   gfc_advance_se_ss_chain (se);
3216 }
3217
3218
3219 /* Build a static initializer.  EXPR is the expression for the initial value.
3220    The other parameters describe the variable of the component being
3221    initialized. EXPR may be null.  */
3222
3223 tree
3224 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3225                       bool array, bool pointer)
3226 {
3227   gfc_se se;
3228
3229   if (!(expr || pointer))
3230     return NULL_TREE;
3231
3232   /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3233      (these are the only two iso_c_binding derived types that can be
3234      used as initialization expressions).  If so, we need to modify
3235      the 'expr' to be that for a (void *).  */
3236   if (expr != NULL && expr->ts.type == BT_DERIVED
3237       && expr->ts.is_iso_c && expr->ts.derived)
3238     {
3239       gfc_symbol *derived = expr->ts.derived;
3240
3241       expr = gfc_int_expr (0);
3242
3243       /* The derived symbol has already been converted to a (void *).  Use
3244          its kind.  */
3245       expr->ts.f90_type = derived->ts.f90_type;
3246       expr->ts.kind = derived->ts.kind;
3247     }
3248
3249   if (array)
3250     {
3251       /* Arrays need special handling.  */
3252       if (pointer)
3253         return gfc_build_null_descriptor (type);
3254       else
3255         return gfc_conv_array_initializer (type, expr);
3256     }
3257   else if (pointer)
3258     return fold_convert (type, null_pointer_node);
3259   else
3260     {
3261       switch (ts->type)
3262         {
3263         case BT_DERIVED:
3264           gfc_init_se (&se, NULL);
3265           gfc_conv_structure (&se, expr, 1);
3266           return se.expr;
3267
3268         case BT_CHARACTER:
3269           return gfc_conv_string_init (ts->cl->backend_decl,expr);
3270
3271         default:
3272           gfc_init_se (&se, NULL);
3273           gfc_conv_constant (&se, expr);
3274           return se.expr;
3275         }
3276     }
3277 }
3278
3279 static tree
3280 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3281 {
3282   gfc_se rse;
3283   gfc_se lse;
3284   gfc_ss *rss;
3285   gfc_ss *lss;
3286   stmtblock_t body;
3287   stmtblock_t block;
3288   gfc_loopinfo loop;
3289   int n;
3290   tree tmp;
3291
3292   gfc_start_block (&block);
3293
3294   /* Initialize the scalarizer.  */
3295   gfc_init_loopinfo (&loop);
3296
3297   gfc_init_se (&lse, NULL);
3298   gfc_init_se (&rse, NULL);
3299
3300   /* Walk the rhs.  */
3301   rss = gfc_walk_expr (expr);
3302   if (rss == gfc_ss_terminator)
3303     {
3304       /* The rhs is scalar.  Add a ss for the expression.  */
3305       rss = gfc_get_ss ();
3306       rss->next = gfc_ss_terminator;
3307       rss->type = GFC_SS_SCALAR;
3308       rss->expr = expr;
3309     }
3310
3311   /* Create a SS for the destination.  */
3312   lss = gfc_get_ss ();
3313   lss->type = GFC_SS_COMPONENT;
3314   lss->expr = NULL;
3315   lss->shape = gfc_get_shape (cm->as->rank);
3316   lss->next = gfc_ss_terminator;
3317   lss->data.info.dimen = cm->as->rank;
3318   lss->data.info.descriptor = dest;
3319   lss->data.info.data = gfc_conv_array_data (dest);
3320   lss->data.info.offset = gfc_conv_array_offset (dest);
3321   for (n = 0; n < cm->as->rank; n++)
3322     {
3323       lss->data.info.dim[n] = n;
3324       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3325       lss->data.info.stride[n] = gfc_index_one_node;
3326
3327       mpz_init (lss->shape[n]);
3328       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3329                cm->as->lower[n]->value.integer);
3330       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3331     }
3332
3333   /* Associate the SS with the loop.  */
3334   gfc_add_ss_to_loop (&loop, lss);
3335   gfc_add_ss_to_loop (&loop, rss);
3336
3337   /* Calculate the bounds of the scalarization.  */
3338   gfc_conv_ss_startstride (&loop);
3339
3340   /* Setup the scalarizing loops.  */
3341   gfc_conv_loop_setup (&loop, &expr->where);
3342
3343   /* Setup the gfc_se structures.  */
3344   gfc_copy_loopinfo_to_se (&lse, &loop);
3345   gfc_copy_loopinfo_to_se (&rse, &loop);
3346
3347   rse.ss = rss;
3348   gfc_mark_ss_chain_used (rss, 1);
3349   lse.ss = lss;
3350   gfc_mark_ss_chain_used (lss, 1);
3351
3352   /* Start the scalarized loop body.  */
3353   gfc_start_scalarized_body (&loop, &body);
3354
3355   gfc_conv_tmp_array_ref (&lse);
3356   if (cm->ts.type == BT_CHARACTER)
3357     lse.string_length = cm->ts.cl->backend_decl;
3358
3359   gfc_conv_expr (&rse, expr);
3360
3361   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3362   gfc_add_expr_to_block (&body, tmp);
3363
3364   gcc_assert (rse.ss == gfc_ss_terminator);
3365
3366   /* Generate the copying loops.  */
3367   gfc_trans_scalarizing_loops (&loop, &body);
3368
3369   /* Wrap the whole thing up.  */
3370   gfc_add_block_to_block (&block, &loop.pre);
3371   gfc_add_block_to_block (&block, &loop.post);
3372
3373   for (n = 0; n < cm->as->rank; n++)
3374     mpz_clear (lss->shape[n]);
3375   gfc_free (lss->shape);
3376
3377   gfc_cleanup_loop (&loop);
3378
3379   return gfc_finish_block (&block);
3380 }
3381
3382
3383 /* Assign a single component of a derived type constructor.  */
3384
3385 static tree
3386 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3387 {
3388   gfc_se se;
3389   gfc_se lse;
3390   gfc_ss *rss;
3391   stmtblock_t block;
3392   tree tmp;
3393   tree offset;
3394   int n;
3395
3396   gfc_start_block (&block);
3397
3398   if (cm->pointer)
3399     {
3400       gfc_init_se (&se, NULL);
3401       /* Pointer component.  */
3402       if (cm->dimension)
3403         {
3404           /* Array pointer.  */
3405           if (expr->expr_type == EXPR_NULL)
3406             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3407           else
3408             {
3409               rss = gfc_walk_expr (expr);
3410               se.direct_byref = 1;
3411               se.expr = dest;
3412               gfc_conv_expr_descriptor (&se, expr, rss);
3413               gfc_add_block_to_block (&block, &se.pre);
3414               gfc_add_block_to_block (&block, &se.post);
3415             }
3416         }
3417       else
3418         {
3419           /* Scalar pointers.  */
3420           se.want_pointer = 1;
3421           gfc_conv_expr (&se, expr);
3422           gfc_add_block_to_block (&block, &se.pre);
3423           gfc_add_modify (&block, dest,
3424                                fold_convert (TREE_TYPE (dest), se.expr));
3425           gfc_add_block_to_block (&block, &se.post);
3426         }
3427     }
3428   else if (cm->dimension)
3429     {
3430       if (cm->allocatable && expr->expr_type == EXPR_NULL)
3431         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3432       else if (cm->allocatable)
3433         {
3434           tree tmp2;
3435
3436           gfc_init_se (&se, NULL);
3437
3438           rss = gfc_walk_expr (expr);
3439           se.want_pointer = 0;
3440           gfc_conv_expr_descriptor (&se, expr, rss);
3441           gfc_add_block_to_block (&block, &se.pre);
3442
3443           tmp = fold_convert (TREE_TYPE (dest), se.expr);
3444           gfc_add_modify (&block, dest, tmp);
3445
3446           if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3447             tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3448                                        cm->as->rank);
3449           else
3450             tmp = gfc_duplicate_allocatable (dest, se.expr,
3451                                              TREE_TYPE(cm->backend_decl),
3452                                              cm->as->rank);
3453
3454           gfc_add_expr_to_block (&block, tmp);
3455
3456           gfc_add_block_to_block (&block, &se.post);
3457           gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3458
3459           /* Shift the lbound and ubound of temporaries to being unity, rather
3460              than zero, based.  Calculate the offset for all cases.  */
3461           offset = gfc_conv_descriptor_offset (dest);
3462           gfc_add_modify (&block, offset, gfc_index_zero_node);
3463           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3464           for (n = 0; n < expr->rank; n++)
3465             {
3466               if (expr->expr_type != EXPR_VARIABLE
3467                     && expr->expr_type != EXPR_CONSTANT)
3468                 {
3469                   tree span;
3470                   tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3471                   span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3472                             gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3473                   gfc_add_modify (&block, tmp,
3474                                        fold_build2 (PLUS_EXPR,
3475                                                     gfc_array_index_type,
3476                                                     span, gfc_index_one_node));
3477                   tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3478                   gfc_add_modify (&block, tmp, gfc_index_one_node);
3479                 }
3480               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3481                                  gfc_conv_descriptor_lbound (dest,
3482                                                              gfc_rank_cst[n]),
3483                                  gfc_conv_descriptor_stride (dest,
3484                                                              gfc_rank_cst[n]));
3485               gfc_add_modify (&block, tmp2, tmp);
3486               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3487               gfc_add_modify (&block, offset, tmp);
3488             }
3489         }
3490       else
3491         {
3492           tmp = gfc_trans_subarray_assign (dest, cm, expr);
3493           gfc_add_expr_to_block (&block, tmp);
3494         }
3495     }
3496   else if (expr->ts.type == BT_DERIVED)
3497     {
3498       if (expr->expr_type != EXPR_STRUCTURE)
3499         {
3500           gfc_init_se (&se, NULL);
3501           gfc_conv_expr (&se, expr);
3502           gfc_add_modify (&block, dest,
3503                                fold_convert (TREE_TYPE (dest), se.expr));
3504         }
3505       else
3506         {
3507           /* Nested constructors.  */
3508           tmp = gfc_trans_structure_assign (dest, expr);
3509           gfc_add_expr_to_block (&block, tmp);
3510         }
3511     }
3512   else
3513     {
3514       /* Scalar component.  */
3515       gfc_init_se (&se, NULL);
3516       gfc_init_se (&lse, NULL);
3517
3518       gfc_conv_expr (&se, expr);
3519       if (cm->ts.type == BT_CHARACTER)
3520         lse.string_length = cm->ts.cl->backend_decl;
3521       lse.expr = dest;
3522       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3523       gfc_add_expr_to_block (&block, tmp);
3524     }
3525   return gfc_finish_block (&block);
3526 }
3527
3528 /* Assign a derived type constructor to a variable.  */
3529
3530 static tree
3531 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3532 {
3533   gfc_constructor *c;
3534   gfc_component *cm;
3535   stmtblock_t block;
3536   tree field;
3537   tree tmp;
3538
3539   gfc_start_block (&block);
3540   cm = expr->ts.derived->components;
3541   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3542     {
3543       /* Skip absent members in default initializers.  */
3544       if (!c->expr)
3545         continue;
3546
3547       /* Update the type/kind of the expression if it represents either
3548          C_NULL_PTR or C_NULL_FUNPTR.  This is done here because this may
3549          be the first place reached for initializing output variables that
3550          have components of type C_PTR/C_FUNPTR that are initialized.  */
3551       if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3552           && c->expr->ts.derived->attr.is_iso_c)
3553         {
3554           c->expr->expr_type = EXPR_NULL;
3555           c->expr->ts.type = c->expr->ts.derived->ts.type;
3556           c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3557           c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3558         }
3559
3560       field = cm->backend_decl;
3561       tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3562                          dest, field, NULL_TREE);
3563       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3564       gfc_add_expr_to_block (&block, tmp);
3565     }
3566   return gfc_finish_block (&block);
3567 }
3568
3569 /* Build an expression for a constructor. If init is nonzero then
3570    this is part of a static variable initializer.  */
3571
3572 void
3573 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3574 {
3575   gfc_constructor *c;
3576   gfc_component *cm;
3577   tree val;
3578   tree type;
3579   tree tmp;
3580   VEC(constructor_elt,gc) *v = NULL;
3581
3582   gcc_assert (se->ss == NULL);
3583   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3584   type = gfc_typenode_for_spec (&expr->ts);
3585
3586   if (!init)
3587     {
3588       /* Create a temporary variable and fill it in.  */
3589       se->expr = gfc_create_var (type, expr->ts.derived->name);
3590       tmp = gfc_trans_structure_assign (se->expr, expr);
3591       gfc_add_expr_to_block (&se->pre, tmp);
3592       return;
3593     }
3594
3595   cm = expr->ts.derived->components;
3596
3597   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3598     {
3599       /* Skip absent members in default initializers and allocatable
3600          components.  Although the latter have a default initializer
3601          of EXPR_NULL,... by default, the static nullify is not needed
3602          since this is done every time we come into scope.  */
3603       if (!c->expr || cm->allocatable)
3604         continue;
3605
3606       val = gfc_conv_initializer (c->expr, &cm->ts,
3607           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3608
3609       /* Append it to the constructor list.  */
3610       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3611     }
3612   se->expr = build_constructor (type, v);
3613   if (init)
3614     TREE_CONSTANT (se->expr) = 1;
3615 }
3616
3617
3618 /* Translate a substring expression.  */
3619
3620 static void
3621 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3622 {
3623   gfc_ref *ref;
3624
3625   ref = expr->ref;
3626
3627   gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3628
3629   se->expr = gfc_build_wide_string_const (expr->ts.kind,
3630                                           expr->value.character.length,
3631                                           expr->value.character.string);
3632
3633   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3634   TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3635
3636   if (ref)
3637     gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3638 }
3639
3640
3641 /* Entry point for expression translation.  Evaluates a scalar quantity.
3642    EXPR is the expression to be translated, and SE is the state structure if
3643    called from within the scalarized.  */
3644
3645 void
3646 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3647 {
3648   if (se->ss && se->ss->expr == expr
3649       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3650     {
3651       /* Substitute a scalar expression evaluated outside the scalarization
3652          loop.  */
3653       se->expr = se->ss->data.scalar.expr;
3654       se->string_length = se->ss->string_length;
3655       gfc_advance_se_ss_chain (se);
3656       return;
3657     }
3658
3659   /* We need to convert the expressions for the iso_c_binding derived types.
3660      C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3661      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
3662      typespec for the C_PTR and C_FUNPTR symbols, which has already been
3663      updated to be an integer with a kind equal to the size of a (void *).  */
3664   if (expr->ts.type == BT_DERIVED && expr->ts.derived
3665       && expr->ts.derived->attr.is_iso_c)
3666     {
3667       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3668           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3669         {
3670           /* Set expr_type to EXPR_NULL, which will result in
3671              null_pointer_node being used below.  */
3672           expr->expr_type = EXPR_NULL;
3673         }
3674       else
3675         {
3676           /* Update the type/kind of the expression to be what the new
3677              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
3678           expr->ts.type = expr->ts.derived->ts.type;
3679           expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3680           expr->ts.kind = expr->ts.derived->ts.kind;
3681         }
3682     }
3683
3684   switch (expr->expr_type)
3685     {
3686     case EXPR_OP:
3687       gfc_conv_expr_op (se, expr);
3688       break;
3689
3690     case EXPR_FUNCTION:
3691       gfc_conv_function_expr (se, expr);
3692       break;
3693
3694     case EXPR_CONSTANT:
3695       gfc_conv_constant (se, expr);
3696       break;
3697
3698     case EXPR_VARIABLE:
3699       gfc_conv_variable (se, expr);
3700       break;
3701
3702     case EXPR_NULL:
3703       se->expr = null_pointer_node;
3704       break;
3705
3706     case EXPR_SUBSTRING:
3707       gfc_conv_substring_expr (se, expr);
3708       break;
3709
3710     case EXPR_STRUCTURE:
3711       gfc_conv_structure (se, expr, 0);
3712       break;
3713
3714     case EXPR_ARRAY:
3715       gfc_conv_array_constructor_expr (se, expr);
3716       break;
3717
3718     default:
3719       gcc_unreachable ();
3720       break;
3721     }
3722 }
3723
3724 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3725    of an assignment.  */
3726 void
3727 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3728 {
3729   gfc_conv_expr (se, expr);
3730   /* All numeric lvalues should have empty post chains.  If not we need to
3731      figure out a way of rewriting an lvalue so that it has no post chain.  */
3732   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3733 }
3734
3735 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3736    numeric expressions.  Used for scalar values where inserting cleanup code
3737    is inconvenient.  */
3738 void
3739 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3740 {
3741   tree val;
3742
3743   gcc_assert (expr->ts.type != BT_CHARACTER);
3744   gfc_conv_expr (se, expr);
3745   if (se->post.head)
3746     {
3747       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3748       gfc_add_modify (&se->pre, val, se->expr);
3749       se->expr = val;
3750       gfc_add_block_to_block (&se->pre, &se->post);
3751     }
3752 }
3753
3754 /* Helper to translate an expression and convert it to a particular type.  */
3755 void
3756 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3757 {
3758   gfc_conv_expr_val (se, expr);
3759   se->expr = convert (type, se->expr);
3760 }
3761
3762
3763 /* Converts an expression so that it can be passed by reference.  Scalar
3764    values only.  */
3765
3766 void
3767 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3768 {
3769   tree var;
3770
3771   if (se->ss && se->ss->expr == expr
3772       && se->ss->type == GFC_SS_REFERENCE)
3773     {
3774       se->expr = se->ss->data.scalar.expr;
3775       se->string_length = se->ss->string_length;
3776       gfc_advance_se_ss_chain (se);
3777       return;
3778     }
3779
3780   if (expr->ts.type == BT_CHARACTER)
3781     {
3782       gfc_conv_expr (se, expr);
3783       gfc_conv_string_parameter (se);
3784       return;
3785     }
3786
3787   if (expr->expr_type == EXPR_VARIABLE)
3788     {
3789       se->want_pointer = 1;
3790       gfc_conv_expr (se, expr);
3791       if (se->post.head)
3792         {
3793           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3794           gfc_add_modify (&se->pre, var, se->expr);
3795           gfc_add_block_to_block (&se->pre, &se->post);
3796           se->expr = var;
3797         }
3798       return;
3799     }
3800
3801   if (expr->expr_type == EXPR_FUNCTION
3802         && expr->symtree->n.sym->attr.pointer
3803         && !expr->symtree->n.sym->attr.dimension)
3804     {
3805       se->want_pointer = 1;
3806       gfc_conv_expr (se, expr);
3807       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3808       gfc_add_modify (&se->pre, var, se->expr);
3809       se->expr = var;
3810       return;
3811     }
3812
3813
3814   gfc_conv_expr (se, expr);
3815
3816   /* Create a temporary var to hold the value.  */
3817   if (TREE_CONSTANT (se->expr))
3818     {
3819       tree tmp = se->expr;
3820       STRIP_TYPE_NOPS (tmp);
3821       var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3822       DECL_INITIAL (var) = tmp;
3823       TREE_STATIC (var) = 1;
3824       pushdecl (var);
3825     }
3826   else
3827     {
3828       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3829       gfc_add_modify (&se->pre, var, se->expr);
3830     }
3831   gfc_add_block_to_block (&se->pre, &se->post);
3832
3833   /* Take the address of that value.  */
3834   se->expr = build_fold_addr_expr (var);
3835 }
3836
3837
3838 tree
3839 gfc_trans_pointer_assign (gfc_code * code)
3840 {
3841   return gfc_trans_pointer_assignment (code->expr, code->expr2);
3842 }
3843
3844
3845 /* Generate code for a pointer assignment.  */
3846
3847 tree
3848 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3849 {
3850   gfc_se lse;
3851   gfc_se rse;
3852   gfc_ss *lss;
3853   gfc_ss *rss;
3854   stmtblock_t block;
3855   tree desc;
3856   tree tmp;
3857   tree decl;
3858
3859
3860   gfc_start_block (&block);
3861
3862   gfc_init_se (&lse, NULL);
3863
3864   lss = gfc_walk_expr (expr1);
3865   rss = gfc_walk_expr (expr2);
3866   if (lss == gfc_ss_terminator)
3867     {
3868       /* Scalar pointers.  */
3869       lse.want_pointer = 1;
3870       gfc_conv_expr (&lse, expr1);
3871       gcc_assert (rss == gfc_ss_terminator);
3872       gfc_init_se (&rse, NULL);
3873       rse.want_pointer = 1;
3874       gfc_conv_expr (&rse, expr2);
3875
3876       if (expr1->symtree->n.sym->attr.proc_pointer
3877           && expr1->symtree->n.sym->attr.dummy)
3878         lse.expr = build_fold_indirect_ref (lse.expr);
3879
3880       gfc_add_block_to_block (&block, &lse.pre);
3881       gfc_add_block_to_block (&block, &rse.pre);
3882       gfc_add_modify (&block, lse.expr,
3883                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3884       gfc_add_block_to_block (&block, &rse.post);
3885       gfc_add_block_to_block (&block, &lse.post);
3886     }
3887   else
3888     {
3889       /* Array pointer.  */
3890       gfc_conv_expr_descriptor (&lse, expr1, lss);
3891       switch (expr2->expr_type)
3892         {
3893         case EXPR_NULL:
3894           /* Just set the data pointer to null.  */
3895           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3896           break;
3897
3898         case EXPR_VARIABLE:
3899           /* Assign directly to the pointer's descriptor.  */
3900           lse.direct_byref = 1;
3901           gfc_conv_expr_descriptor (&lse, expr2, rss);
3902
3903           /* If this is a subreference array pointer assignment, use the rhs
3904              descriptor element size for the lhs span.  */
3905           if (expr1->symtree->n.sym->attr.subref_array_pointer)
3906             {
3907               decl = expr1->symtree->n.sym->backend_decl;
3908               gfc_init_se (&rse, NULL);
3909               rse.descriptor_only = 1;
3910               gfc_conv_expr (&rse, expr2);
3911               tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
3912               tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
3913               if (!INTEGER_CST_P (tmp))
3914                 gfc_add_block_to_block (&lse.post, &rse.pre);
3915               gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
3916             }
3917
3918           break;
3919
3920         default:
3921           /* Assign to a temporary descriptor and then copy that
3922              temporary to the pointer.  */
3923           desc = lse.expr;
3924           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3925
3926           lse.expr = tmp;
3927           lse.direct_byref = 1;
3928           gfc_conv_expr_descriptor (&lse, expr2, rss);
3929           gfc_add_modify (&lse.pre, desc, tmp);
3930           break;
3931         }
3932       gfc_add_block_to_block (&block, &lse.pre);
3933       gfc_add_block_to_block (&block, &lse.post);
3934     }
3935   return gfc_finish_block (&block);
3936 }
3937
3938
3939 /* Makes sure se is suitable for passing as a function string parameter.  */
3940 /* TODO: Need to check all callers of this function.  It may be abused.  */
3941
3942 void
3943 gfc_conv_string_parameter (gfc_se * se)
3944 {
3945   tree type;
3946
3947   if (TREE_CODE (se->expr) == STRING_CST)
3948     {
3949       type = TREE_TYPE (TREE_TYPE (se->expr));
3950       se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3951       return;
3952     }
3953
3954   if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
3955     {
3956       if (TREE_CODE (se->expr) != INDIRECT_REF)
3957         {
3958           type = TREE_TYPE (se->expr);
3959           se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3960         }
3961       else
3962         {
3963           type = gfc_get_character_type_len (gfc_default_character_kind,
3964                                              se->string_length);
3965           type = build_pointer_type (type);
3966           se->expr = gfc_build_addr_expr (type, se->expr);
3967         }
3968     }
3969
3970   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3971   gcc_assert (se->string_length
3972           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3973 }
3974
3975
3976 /* Generate code for assignment of scalar variables.  Includes character
3977    strings and derived types with allocatable components.  */
3978
3979 tree
3980 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3981                          bool l_is_temp, bool r_is_var)
3982 {
3983   stmtblock_t block;
3984   tree tmp;
3985   tree cond;
3986
3987   gfc_init_block (&block);
3988
3989   if (ts.type == BT_CHARACTER)
3990     {
3991       tree rlen = NULL;
3992       tree llen = NULL;
3993
3994       if (lse->string_length != NULL_TREE)
3995         {
3996           gfc_conv_string_parameter (lse);
3997           gfc_add_block_to_block (&block, &lse->pre);
3998           llen = lse->string_length;
3999         }
4000
4001       if (rse->string_length != NULL_TREE)
4002         {
4003           gcc_assert (rse->string_length != NULL_TREE);
4004           gfc_conv_string_parameter (rse);
4005           gfc_add_block_to_block (&block, &rse->pre);
4006           rlen = rse->string_length;
4007         }
4008
4009       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4010                              rse->expr, ts.kind);
4011     }
4012   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4013     {
4014       cond = NULL_TREE;
4015
4016       /* Are the rhs and the lhs the same?  */
4017       if (r_is_var)
4018         {
4019           cond = fold_build2 (EQ_EXPR, boolean_type_node,
4020                               build_fold_addr_expr (lse->expr),
4021                               build_fold_addr_expr (rse->expr));
4022           cond = gfc_evaluate_now (cond, &lse->pre);
4023         }
4024
4025       /* Deallocate the lhs allocated components as long as it is not
4026          the same as the rhs.  This must be done following the assignment
4027          to prevent deallocating data that could be used in the rhs
4028          expression.  */
4029       if (!l_is_temp)
4030         {
4031           tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4032           tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4033           if (r_is_var)
4034             tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4035           gfc_add_expr_to_block (&lse->post, tmp);
4036         }
4037
4038       gfc_add_block_to_block (&block, &rse->pre);
4039       gfc_add_block_to_block (&block, &lse->pre);
4040
4041       gfc_add_modify (&block, lse->expr,
4042                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
4043
4044       /* Do a deep copy if the rhs is a variable, if it is not the
4045          same as the lhs.  */
4046       if (r_is_var)
4047         {
4048           tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4049           tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4050           gfc_add_expr_to_block (&block, tmp);
4051         }
4052     }
4053   else
4054     {
4055       gfc_add_block_to_block (&block, &lse->pre);
4056       gfc_add_block_to_block (&block, &rse->pre);
4057
4058       gfc_add_modify (&block, lse->expr,
4059                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
4060     }
4061
4062   gfc_add_block_to_block (&block, &lse->post);
4063   gfc_add_block_to_block (&block, &rse->post);
4064
4065   return gfc_finish_block (&block);
4066 }
4067
4068
4069 /* Try to translate array(:) = func (...), where func is a transformational
4070    array function, without using a temporary.  Returns NULL is this isn't the
4071    case.  */
4072
4073 static tree
4074 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4075 {
4076   gfc_se se;
4077   gfc_ss *ss;
4078   gfc_ref * ref;
4079   bool seen_array_ref;
4080
4081   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
4082   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4083     return NULL;
4084
4085   /* Elemental functions don't need a temporary anyway.  */
4086   if (expr2->value.function.esym != NULL
4087       && expr2->value.function.esym->attr.elemental)
4088     return NULL;
4089
4090   /* Fail if EXPR1 can't be expressed as a descriptor.  */
4091   if (gfc_ref_needs_temporary_p (expr1->ref))
4092     return NULL;
4093
4094   /* Functions returning pointers need temporaries.  */
4095   if (expr2->symtree->n.sym->attr.pointer
4096       || expr2->symtree->n.sym->attr.allocatable)
4097     return NULL;
4098
4099   /* Character array functions need temporaries unless the
4100      character lengths are the same.  */
4101   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4102     {
4103       if (expr1->ts.cl->length == NULL
4104             || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4105         return NULL;
4106
4107       if (expr2->ts.cl->length == NULL
4108             || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4109         return NULL;
4110
4111       if (mpz_cmp (expr1->ts.cl->length->value.integer,
4112                      expr2->ts.cl->length->value.integer) != 0)
4113         return NULL;
4114     }
4115
4116   /* Check that no LHS component references appear during an array
4117      reference. This is needed because we do not have the means to
4118      span any arbitrary stride with an array descriptor. This check
4119      is not needed for the rhs because the function result has to be
4120      a complete type.  */
4121   seen_array_ref = false;
4122   for (ref = expr1->ref; ref; ref = ref->next)
4123     {
4124       if (ref->type == REF_ARRAY)
4125         seen_array_ref= true;
4126       else if (ref->type == REF_COMPONENT && seen_array_ref)
4127         return NULL;
4128     }
4129
4130   /* Check for a dependency.  */
4131   if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4132                                    expr2->value.function.esym,
4133                                    expr2->value.function.actual))
4134     return NULL;
4135
4136   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4137      functions.  */
4138   gcc_assert (expr2->value.function.isym
4139               || (gfc_return_by_reference (expr2->value.function.esym)
4140               && expr2->value.function.esym->result->attr.dimension));
4141
4142   ss = gfc_walk_expr (expr1);
4143   gcc_assert (ss != gfc_ss_terminator);
4144   gfc_init_se (&se, NULL);
4145   gfc_start_block (&se.pre);
4146   se.want_pointer = 1;
4147
4148   gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
4149
4150   se.direct_byref = 1;
4151   se.ss = gfc_walk_expr (expr2);
4152   gcc_assert (se.ss != gfc_ss_terminator);
4153   gfc_conv_function_expr (&se, expr2);
4154   gfc_add_block_to_block (&se.pre, &se.post);
4155
4156   return gfc_finish_block (&se.pre);
4157 }
4158
4159 /* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
4160
4161 static bool
4162 is_zero_initializer_p (gfc_expr * expr)
4163 {
4164   if (expr->expr_type != EXPR_CONSTANT)
4165     return false;
4166
4167   /* We ignore constants with prescribed memory representations for now.  */
4168   if (expr->representation.string)
4169     return false;
4170
4171   switch (expr->ts.type)
4172     {
4173     case BT_INTEGER:
4174       return mpz_cmp_si (expr->value.integer, 0) == 0;
4175
4176     case BT_REAL:
4177       return mpfr_zero_p (expr->value.real)
4178              && MPFR_SIGN (expr->value.real) >= 0;
4179
4180     case BT_LOGICAL:
4181       return expr->value.logical == 0;
4182
4183     case BT_COMPLEX:
4184       return mpfr_zero_p (expr->value.complex.r)
4185              && MPFR_SIGN (expr->value.complex.r) >= 0
4186              && mpfr_zero_p (expr->value.complex.i)
4187              && MPFR_SIGN (expr->value.complex.i) >= 0;
4188
4189     default:
4190       break;
4191     }
4192   return false;
4193 }
4194
4195 /* Try to efficiently translate array(:) = 0.  Return NULL if this
4196    can't be done.  */
4197
4198 static tree
4199 gfc_trans_zero_assign (gfc_expr * expr)
4200 {
4201   tree dest, len, type;
4202   tree tmp;
4203   gfc_symbol *sym;
4204
4205   sym = expr->symtree->n.sym;
4206   dest = gfc_get_symbol_decl (sym);
4207
4208   type = TREE_TYPE (dest);
4209   if (POINTER_TYPE_P (type))
4210     type = TREE_TYPE (type);
4211   if (!GFC_ARRAY_TYPE_P (type))
4212     return NULL_TREE;
4213
4214   /* Determine the length of the array.  */
4215   len = GFC_TYPE_ARRAY_SIZE (type);
4216   if (!len || TREE_CODE (len) != INTEGER_CST)
4217     return NULL_TREE;
4218
4219   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4220   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4221                      fold_convert (gfc_array_index_type, tmp));
4222
4223   /* Convert arguments to the correct types.  */
4224   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4225     dest = gfc_build_addr_expr (pvoid_type_node, dest);
4226   else
4227     dest = fold_convert (pvoid_type_node, dest);
4228   len = fold_convert (size_type_node, len);
4229
4230   /* Construct call to __builtin_memset.  */
4231   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4232                          3, dest, integer_zero_node, len);
4233   return fold_convert (void_type_node, tmp);
4234 }
4235
4236
4237 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4238    that constructs the call to __builtin_memcpy.  */
4239
4240 static tree
4241 gfc_build_memcpy_call (tree dst, tree src, tree len)
4242 {
4243   tree tmp;
4244
4245   /* Convert arguments to the correct types.  */
4246   if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4247     dst = gfc_build_addr_expr (pvoid_type_node, dst);
4248   else
4249     dst = fold_convert (pvoid_type_node, dst);
4250
4251   if (!POINTER_TYPE_P (TREE_TYPE (src)))
4252     src = gfc_build_addr_expr (pvoid_type_node, src);
4253   else
4254     src = fold_convert (pvoid_type_node, src);
4255
4256   len = fold_convert (size_type_node, len);
4257
4258   /* Construct call to __builtin_memcpy.  */
4259   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4260   return fold_convert (void_type_node, tmp);
4261 }
4262
4263
4264 /* Try to efficiently translate dst(:) = src(:).  Return NULL if this
4265    can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
4266    source/rhs, both are gfc_full_array_ref_p which have been checked for
4267    dependencies.  */
4268
4269 static tree
4270 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4271 {
4272   tree dst, dlen, dtype;
4273   tree src, slen, stype;
4274   tree tmp;
4275
4276   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4277   src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4278
4279   dtype = TREE_TYPE (dst);
4280   if (POINTER_TYPE_P (dtype))
4281     dtype = TREE_TYPE (dtype);
4282   stype = TREE_TYPE (src);
4283   if (POINTER_TYPE_P (stype))
4284     stype = TREE_TYPE (stype);
4285
4286   if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4287     return NULL_TREE;
4288
4289   /* Determine the lengths of the arrays.  */
4290   dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4291   if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4292     return NULL_TREE;
4293   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4294   dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4295                       fold_convert (gfc_array_index_type, tmp));
4296
4297   slen = GFC_TYPE_ARRAY_SIZE (stype);
4298   if (!slen || TREE_CODE (slen) != INTEGER_CST)
4299     return NULL_TREE;
4300   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4301   slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4302                       fold_convert (gfc_array_index_type, tmp));
4303
4304   /* Sanity check that they are the same.  This should always be
4305      the case, as we should already have checked for conformance.  */
4306   if (!tree_int_cst_equal (slen, dlen))
4307     return NULL_TREE;
4308
4309   return gfc_build_memcpy_call (dst, src, dlen);
4310 }
4311
4312
4313 /* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
4314    this can't be done.  EXPR1 is the destination/lhs for which
4315    gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
4316
4317 static tree
4318 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4319 {
4320   unsigned HOST_WIDE_INT nelem;
4321   tree dst, dtype;
4322   tree src, stype;
4323   tree len;
4324   tree tmp;
4325
4326   nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4327   if (nelem == 0)
4328     return NULL_TREE;
4329
4330   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4331   dtype = TREE_TYPE (dst);
4332   if (POINTER_TYPE_P (dtype))
4333     dtype = TREE_TYPE (dtype);
4334   if (!GFC_ARRAY_TYPE_P (dtype))
4335     return NULL_TREE;
4336
4337   /* Determine the lengths of the array.  */
4338   len = GFC_TYPE_ARRAY_SIZE (dtype);
4339   if (!len || TREE_CODE (len) != INTEGER_CST)
4340     return NULL_TREE;
4341
4342   /* Confirm that the constructor is the same size.  */
4343   if (compare_tree_int (len, nelem) != 0)
4344     return NULL_TREE;
4345
4346   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4347   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4348                      fold_convert (gfc_array_index_type, tmp));
4349
4350   stype = gfc_typenode_for_spec (&expr2->ts);
4351   src = gfc_build_constant_array_constructor (expr2, stype);
4352
4353   stype = TREE_TYPE (src);
4354   if (POINTER_TYPE_P (stype))
4355     stype = TREE_TYPE (stype);
4356
4357   return gfc_build_memcpy_call (dst, src, len);
4358 }
4359
4360
4361 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4362    assignment.  EXPR1 is the destination/RHS and EXPR2 is the source/LHS.  */
4363
4364 static tree
4365 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4366 {
4367   gfc_se lse;
4368   gfc_se rse;
4369   gfc_ss *lss;
4370   gfc_ss *lss_section;
4371   gfc_ss *rss;
4372   gfc_loopinfo loop;
4373   tree tmp;
4374   stmtblock_t block;
4375   stmtblock_t body;
4376   bool l_is_temp;
4377
4378   /* Assignment of the form lhs = rhs.  */
4379   gfc_start_block (&block);
4380
4381   gfc_init_se (&lse, NULL);
4382   gfc_init_se (&rse, NULL);
4383
4384   /* Walk the lhs.  */
4385   lss = gfc_walk_expr (expr1);
4386   rss = NULL;
4387   if (lss != gfc_ss_terminator)
4388     {
4389       /* The assignment needs scalarization.  */
4390       lss_section = lss;
4391
4392       /* Find a non-scalar SS from the lhs.  */
4393       while (lss_section != gfc_ss_terminator
4394              && lss_section->type != GFC_SS_SECTION)
4395         lss_section = lss_section->next;
4396
4397       gcc_assert (lss_section != gfc_ss_terminator);
4398
4399       /* Initialize the scalarizer.  */
4400       gfc_init_loopinfo (&loop);
4401
4402       /* Walk the rhs.  */
4403       rss = gfc_walk_expr (expr2);
4404       if (rss == gfc_ss_terminator)
4405         {
4406           /* The rhs is scalar.  Add a ss for the expression.  */
4407           rss = gfc_get_ss ();
4408           rss->next = gfc_ss_terminator;
4409           rss->type = GFC_SS_SCALAR;
4410           rss->expr = expr2;
4411         }
4412       /* Associate the SS with the loop.  */
4413       gfc_add_ss_to_loop (&loop, lss);
4414       gfc_add_ss_to_loop (&loop, rss);
4415
4416       /* Calculate the bounds of the scalarization.  */
4417       gfc_conv_ss_startstride (&loop);
4418       /* Resolve any data dependencies in the statement.  */
4419       gfc_conv_resolve_dependencies (&loop, lss, rss);
4420       /* Setup the scalarizing loops.  */
4421       gfc_conv_loop_setup (&loop, &expr2->where);
4422
4423       /* Setup the gfc_se structures.  */
4424       gfc_copy_loopinfo_to_se (&lse, &loop);
4425       gfc_copy_loopinfo_to_se (&rse, &loop);
4426
4427       rse.ss = rss;
4428       gfc_mark_ss_chain_used (rss, 1);
4429       if (loop.temp_ss == NULL)
4430         {
4431           lse.ss = lss;
4432           gfc_mark_ss_chain_used (lss, 1);
4433         }
4434       else
4435         {
4436           lse.ss = loop.temp_ss;
4437           gfc_mark_ss_chain_used (lss, 3);
4438           gfc_mark_ss_chain_used (loop.temp_ss, 3);
4439         }
4440
4441       /* Start the scalarized loop body.  */
4442       gfc_start_scalarized_body (&loop, &body);
4443     }
4444   else
4445     gfc_init_block (&body);
4446
4447   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4448
4449   /* Translate the expression.  */
4450   gfc_conv_expr (&rse, expr2);
4451
4452   if (l_is_temp)
4453     {
4454       gfc_conv_tmp_array_ref (&lse);
4455       gfc_advance_se_ss_chain (&lse);
4456     }
4457   else
4458     gfc_conv_expr (&lse, expr1);
4459
4460   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4461                                  l_is_temp || init_flag,
4462                                  expr2->expr_type == EXPR_VARIABLE);
4463   gfc_add_expr_to_block (&body, tmp);
4464
4465   if (lss == gfc_ss_terminator)
4466     {
4467       /* Use the scalar assignment as is.  */
4468       gfc_add_block_to_block (&block, &body);
4469     }
4470   else
4471     {
4472       gcc_assert (lse.ss == gfc_ss_terminator
4473                   && rse.ss == gfc_ss_terminator);
4474
4475       if (l_is_temp)
4476         {
4477           gfc_trans_scalarized_loop_boundary (&loop, &body);
4478
4479           /* We need to copy the temporary to the actual lhs.  */
4480           gfc_init_se (&lse, NULL);
4481           gfc_init_se (&rse, NULL);
4482           gfc_copy_loopinfo_to_se (&lse, &loop);
4483           gfc_copy_loopinfo_to_se (&rse, &loop);
4484
4485           rse.ss = loop.temp_ss;
4486           lse.ss = lss;
4487
4488           gfc_conv_tmp_array_ref (&rse);
4489           gfc_advance_se_ss_chain (&rse);
4490           gfc_conv_expr (&lse, expr1);
4491
4492           gcc_assert (lse.ss == gfc_ss_terminator
4493                       && rse.ss == gfc_ss_terminator);
4494
4495           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4496                                          false, false);
4497           gfc_add_expr_to_block (&body, tmp);
4498         }
4499
4500       /* Generate the copying loops.  */
4501       gfc_trans_scalarizing_loops (&loop, &body);
4502
4503       /* Wrap the whole thing up.  */
4504       gfc_add_block_to_block (&block, &loop.pre);
4505       gfc_add_block_to_block (&block, &loop.post);
4506
4507       gfc_cleanup_loop (&loop);
4508     }
4509
4510   return gfc_finish_block (&block);
4511 }
4512
4513
4514 /* Check whether EXPR is a copyable array.  */
4515
4516 static bool
4517 copyable_array_p (gfc_expr * expr)
4518 {
4519   if (expr->expr_type != EXPR_VARIABLE)
4520     return false;
4521
4522   /* First check it's an array.  */
4523   if (expr->rank < 1 || !expr->ref || expr->ref->next)
4524     return false;
4525
4526   if (!gfc_full_array_ref_p (expr->ref))
4527     return false;
4528
4529   /* Next check that it's of a simple enough type.  */
4530   switch (expr->ts.type)
4531     {
4532     case BT_INTEGER:
4533     case BT_REAL:
4534     case BT_COMPLEX:
4535     case BT_LOGICAL:
4536       return true;
4537
4538     case BT_CHARACTER:
4539       return false;
4540
4541     case BT_DERIVED:
4542       return !expr->ts.derived->attr.alloc_comp;
4543
4544     default:
4545       break;
4546     }
4547
4548   return false;
4549 }
4550
4551 /* Translate an assignment.  */
4552
4553 tree
4554 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4555 {
4556   tree tmp;
4557
4558   /* Special case a single function returning an array.  */
4559   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4560     {
4561       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4562       if (tmp)
4563         return tmp;
4564     }
4565
4566   /* Special case assigning an array to zero.  */
4567   if (copyable_array_p (expr1)
4568       && is_zero_initializer_p (expr2))
4569     {
4570       tmp = gfc_trans_zero_assign (expr1);
4571       if (tmp)
4572         return tmp;
4573     }
4574
4575   /* Special case copying one array to another.  */
4576   if (copyable_array_p (expr1)
4577       && copyable_array_p (expr2)
4578       && gfc_compare_types (&expr1->ts, &expr2->ts)
4579       && !gfc_check_dependency (expr1, expr2, 0))
4580     {
4581       tmp = gfc_trans_array_copy (expr1, expr2);
4582       if (tmp)
4583         return tmp;
4584     }
4585
4586   /* Special case initializing an array from a constant array constructor.  */
4587   if (copyable_array_p (expr1)
4588       && expr2->expr_type == EXPR_ARRAY
4589       && gfc_compare_types (&expr1->ts, &expr2->ts))
4590     {
4591       tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4592       if (tmp)
4593         return tmp;
4594     }
4595
4596   /* Fallback to the scalarizer to generate explicit loops.  */
4597   return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4598 }
4599
4600 tree
4601 gfc_trans_init_assign (gfc_code * code)
4602 {
4603   return gfc_trans_assignment (code->expr, code->expr2, true);
4604 }
4605
4606 tree
4607 gfc_trans_assign (gfc_code * code)
4608 {
4609   return gfc_trans_assignment (code->expr, code->expr2, false);
4610 }