gcc/fortran/trans-expr.c

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