gcc/fortran/trans-expr.c

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