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->pointer && c->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
2016   return;
2017 }
2018
2019
2020 /* Evaluate interface expression EXPR using MAPPING.  Store the result
2021    in SE.  */
2022
2023 void
2024 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2025                              gfc_se * se, gfc_expr * expr)
2026 {
2027   expr = gfc_copy_expr (expr);
2028   gfc_apply_interface_mapping_to_expr (mapping, expr);
2029   gfc_conv_expr (se, expr);
2030   se->expr = gfc_evaluate_now (se->expr, &se->pre);
2031   gfc_free_expr (expr);
2032 }
2033
2034
2035 /* Returns a reference to a temporary array into which a component of
2036    an actual argument derived type array is copied and then returned
2037    after the function call.  */
2038 void
2039 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2040                            int g77, sym_intent intent)
2041 {
2042   gfc_se lse;
2043   gfc_se rse;
2044   gfc_ss *lss;
2045   gfc_ss *rss;
2046   gfc_loopinfo loop;
2047   gfc_loopinfo loop2;
2048   gfc_ss_info *info;
2049   tree offset;
2050   tree tmp_index;
2051   tree tmp;
2052   tree base_type;
2053   stmtblock_t body;
2054   int n;
2055
2056   gcc_assert (expr->expr_type == EXPR_VARIABLE);
2057
2058   gfc_init_se (&lse, NULL);
2059   gfc_init_se (&rse, NULL);
2060
2061   /* Walk the argument expression.  */
2062   rss = gfc_walk_expr (expr);
2063
2064   gcc_assert (rss != gfc_ss_terminator);
2065
2066   /* Initialize the scalarizer.  */
2067   gfc_init_loopinfo (&loop);
2068   gfc_add_ss_to_loop (&loop, rss);
2069
2070   /* Calculate the bounds of the scalarization.  */
2071   gfc_conv_ss_startstride (&loop);
2072
2073   /* Build an ss for the temporary.  */
2074   if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2075     gfc_conv_string_length (expr->ts.cl, &parmse->pre);
2076
2077   base_type = gfc_typenode_for_spec (&expr->ts);
2078   if (GFC_ARRAY_TYPE_P (base_type)
2079                 || GFC_DESCRIPTOR_TYPE_P (base_type))
2080     base_type = gfc_get_element_type (base_type);
2081
2082   loop.temp_ss = gfc_get_ss ();;
2083   loop.temp_ss->type = GFC_SS_TEMP;
2084   loop.temp_ss->data.temp.type = base_type;
2085
2086   if (expr->ts.type == BT_CHARACTER)
2087     loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2088   else
2089     loop.temp_ss->string_length = NULL;
2090
2091   parmse->string_length = loop.temp_ss->string_length;
2092   loop.temp_ss->data.temp.dimen = loop.dimen;
2093   loop.temp_ss->next = gfc_ss_terminator;
2094
2095   /* Associate the SS with the loop.  */
2096   gfc_add_ss_to_loop (&loop, loop.temp_ss);
2097
2098   /* Setup the scalarizing loops.  */
2099   gfc_conv_loop_setup (&loop, &expr->where);
2100
2101   /* Pass the temporary descriptor back to the caller.  */
2102   info = &loop.temp_ss->data.info;
2103   parmse->expr = info->descriptor;
2104
2105   /* Setup the gfc_se structures.  */
2106   gfc_copy_loopinfo_to_se (&lse, &loop);
2107   gfc_copy_loopinfo_to_se (&rse, &loop);
2108
2109   rse.ss = rss;
2110   lse.ss = loop.temp_ss;
2111   gfc_mark_ss_chain_used (rss, 1);
2112   gfc_mark_ss_chain_used (loop.temp_ss, 1);
2113
2114   /* Start the scalarized loop body.  */
2115   gfc_start_scalarized_body (&loop, &body);
2116
2117   /* Translate the expression.  */
2118   gfc_conv_expr (&rse, expr);
2119
2120   gfc_conv_tmp_array_ref (&lse);
2121   gfc_advance_se_ss_chain (&lse);
2122
2123   if (intent != INTENT_OUT)
2124     {
2125       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2126       gfc_add_expr_to_block (&body, tmp);
2127       gcc_assert (rse.ss == gfc_ss_terminator);
2128       gfc_trans_scalarizing_loops (&loop, &body);
2129     }
2130   else
2131     {
2132       /* Make sure that the temporary declaration survives by merging
2133        all the loop declarations into the current context.  */
2134       for (n = 0; n < loop.dimen; n++)
2135         {
2136           gfc_merge_block_scope (&body);
2137           body = loop.code[loop.order[n]];
2138         }
2139       gfc_merge_block_scope (&body);
2140     }
2141
2142   /* Add the post block after the second loop, so that any
2143      freeing of allocated memory is done at the right time.  */
2144   gfc_add_block_to_block (&parmse->pre, &loop.pre);
2145
2146   /**********Copy the temporary back again.*********/
2147
2148   gfc_init_se (&lse, NULL);
2149   gfc_init_se (&rse, NULL);
2150
2151   /* Walk the argument expression.  */
2152   lss = gfc_walk_expr (expr);
2153   rse.ss = loop.temp_ss;
2154   lse.ss = lss;
2155
2156   /* Initialize the scalarizer.  */
2157   gfc_init_loopinfo (&loop2);
2158   gfc_add_ss_to_loop (&loop2, lss);
2159
2160   /* Calculate the bounds of the scalarization.  */
2161   gfc_conv_ss_startstride (&loop2);
2162
2163   /* Setup the scalarizing loops.  */
2164   gfc_conv_loop_setup (&loop2, &expr->where);
2165
2166   gfc_copy_loopinfo_to_se (&lse, &loop2);
2167   gfc_copy_loopinfo_to_se (&rse, &loop2);
2168
2169   gfc_mark_ss_chain_used (lss, 1);
2170   gfc_mark_ss_chain_used (loop.temp_ss, 1);
2171
2172   /* Declare the variable to hold the temporary offset and start the
2173      scalarized loop body.  */
2174   offset = gfc_create_var (gfc_array_index_type, NULL);
2175   gfc_start_scalarized_body (&loop2, &body);
2176
2177   /* Build the offsets for the temporary from the loop variables.  The
2178      temporary array has lbounds of zero and strides of one in all
2179      dimensions, so this is very simple.  The offset is only computed
2180      outside the innermost loop, so the overall transfer could be
2181      optimized further.  */
2182   info = &rse.ss->data.info;
2183
2184   tmp_index = gfc_index_zero_node;
2185   for (n = info->dimen - 1; n > 0; n--)
2186     {
2187       tree tmp_str;
2188       tmp = rse.loop->loopvar[n];
2189       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2190                          tmp, rse.loop->from[n]);
2191       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2192                          tmp, tmp_index);
2193
2194       tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2195                              rse.loop->to[n-1], rse.loop->from[n-1]);
2196       tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2197                              tmp_str, gfc_index_one_node);
2198
2199       tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2200                                tmp, tmp_str);
2201     }
2202
2203   tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2204                            tmp_index, rse.loop->from[0]);
2205   gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2206
2207   tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2208                            rse.loop->loopvar[0], offset);
2209
2210   /* Now use the offset for the reference.  */
2211   tmp = build_fold_indirect_ref (info->data);
2212   rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2213
2214   if (expr->ts.type == BT_CHARACTER)
2215     rse.string_length = expr->ts.cl->backend_decl;
2216
2217   gfc_conv_expr (&lse, expr);
2218
2219   gcc_assert (lse.ss == gfc_ss_terminator);
2220
2221   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2222   gfc_add_expr_to_block (&body, tmp);
2223
2224   /* Generate the copying loops.  */
2225   gfc_trans_scalarizing_loops (&loop2, &body);
2226
2227   /* Wrap the whole thing up by adding the second loop to the post-block
2228      and following it by the post-block of the first loop.  In this way,
2229      if the temporary needs freeing, it is done after use!  */
2230   if (intent != INTENT_IN)
2231     {
2232       gfc_add_block_to_block (&parmse->post, &loop2.pre);
2233       gfc_add_block_to_block (&parmse->post, &loop2.post);
2234     }
2235
2236   gfc_add_block_to_block (&parmse->post, &loop.post);
2237
2238   gfc_cleanup_loop (&loop);
2239   gfc_cleanup_loop (&loop2);
2240
2241   /* Pass the string length to the argument expression.  */
2242   if (expr->ts.type == BT_CHARACTER)
2243     parmse->string_length = expr->ts.cl->backend_decl;
2244
2245   /* We want either the address for the data or the address of the descriptor,
2246      depending on the mode of passing array arguments.  */
2247   if (g77)
2248     parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2249   else
2250     parmse->expr = build_fold_addr_expr (parmse->expr);
2251
2252   return;
2253 }
2254
2255
2256 /* Generate the code for argument list functions.  */
2257
2258 static void
2259 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2260 {
2261   /* Pass by value for g77 %VAL(arg), pass the address
2262      indirectly for %LOC, else by reference.  Thus %REF
2263      is a "do-nothing" and %LOC is the same as an F95
2264      pointer.  */
2265   if (strncmp (name, "%VAL", 4) == 0)
2266     gfc_conv_expr (se, expr);
2267   else if (strncmp (name, "%LOC", 4) == 0)
2268     {
2269       gfc_conv_expr_reference (se, expr);
2270       se->expr = gfc_build_addr_expr (NULL, se->expr);
2271     }
2272   else if (strncmp (name, "%REF", 4) == 0)
2273     gfc_conv_expr_reference (se, expr);
2274   else
2275     gfc_error ("Unknown argument list function at %L", &expr->where);
2276 }
2277
2278
2279 /* Generate code for a procedure call.  Note can return se->post != NULL.
2280    If se->direct_byref is set then se->expr contains the return parameter.
2281    Return nonzero, if the call has alternate specifiers.  */
2282
2283 int
2284 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2285                         gfc_actual_arglist * arg, tree append_args)
2286 {
2287   gfc_interface_mapping mapping;
2288   tree arglist;
2289   tree retargs;
2290   tree tmp;
2291   tree fntype;
2292   gfc_se parmse;
2293   gfc_ss *argss;
2294   gfc_ss_info *info;
2295   int byref;
2296   int parm_kind;
2297   tree type;
2298   tree var;
2299   tree len;
2300   tree stringargs;
2301   gfc_formal_arglist *formal;
2302   int has_alternate_specifier = 0;
2303   bool need_interface_mapping;
2304   bool callee_alloc;
2305   gfc_typespec ts;
2306   gfc_charlen cl;
2307   gfc_expr *e;
2308   gfc_symbol *fsym;
2309   stmtblock_t post;
2310   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2311
2312   arglist = NULL_TREE;
2313   retargs = NULL_TREE;
2314   stringargs = NULL_TREE;
2315   var = NULL_TREE;
2316   len = NULL_TREE;
2317   gfc_clear_ts (&ts);
2318
2319   if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2320     {
2321       if (sym->intmod_sym_id == ISOCBINDING_LOC)
2322         {
2323           if (arg->expr->rank == 0)
2324             gfc_conv_expr_reference (se, arg->expr);
2325           else
2326             {
2327               int f;
2328               /* This is really the actual arg because no formal arglist is
2329                  created for C_LOC.      */
2330               fsym = arg->expr->symtree->n.sym;
2331
2332               /* We should want it to do g77 calling convention.  */
2333               f = (fsym != NULL)
2334                 && !(fsym->attr.pointer || fsym->attr.allocatable)
2335                 && fsym->as->type != AS_ASSUMED_SHAPE;
2336               f = f || !sym->attr.always_explicit;
2337
2338               argss = gfc_walk_expr (arg->expr);
2339               gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
2340             }
2341
2342           /* TODO -- the following two lines shouldn't be necessary, but
2343             they're removed a bug is exposed later in the codepath.
2344             This is workaround was thus introduced, but will have to be
2345             removed; please see PR 35150 for details about the issue.  */
2346           se->expr = convert (pvoid_type_node, se->expr);
2347           se->expr = gfc_evaluate_now (se->expr, &se->pre);
2348
2349           return 0;
2350         }
2351       else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2352         {
2353           arg->expr->ts.type = sym->ts.derived->ts.type;
2354           arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2355           arg->expr->ts.kind = sym->ts.derived->ts.kind;
2356           gfc_conv_expr_reference (se, arg->expr);
2357
2358           return 0;
2359         }
2360       else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2361                  && arg->next->expr->rank == 0)
2362                || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2363         {
2364           /* Convert c_f_pointer if fptr is a scalar
2365              and convert c_f_procpointer.  */
2366           gfc_se cptrse;
2367           gfc_se fptrse;
2368
2369           gfc_init_se (&cptrse, NULL);
2370           gfc_conv_expr (&cptrse, arg->expr);
2371           gfc_add_block_to_block (&se->pre, &cptrse.pre);
2372           gfc_add_block_to_block (&se->post, &cptrse.post);
2373
2374           gfc_init_se (&fptrse, NULL);
2375           if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2376               fptrse.want_pointer = 1;
2377
2378           gfc_conv_expr (&fptrse, arg->next->expr);
2379           gfc_add_block_to_block (&se->pre, &fptrse.pre);
2380           gfc_add_block_to_block (&se->post, &fptrse.post);
2381
2382           tmp = arg->next->expr->symtree->n.sym->backend_decl;
2383           se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
2384                                   fold_convert (TREE_TYPE (tmp), cptrse.expr));
2385
2386           return 0;
2387         }
2388       else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2389         {
2390           gfc_se arg1se;
2391           gfc_se arg2se;
2392
2393           /* Build the addr_expr for the first argument.  The argument is
2394              already an *address* so we don't need to set want_pointer in
2395              the gfc_se.  */
2396           gfc_init_se (&arg1se, NULL);
2397           gfc_conv_expr (&arg1se, arg->expr);
2398           gfc_add_block_to_block (&se->pre, &arg1se.pre);
2399           gfc_add_block_to_block (&se->post, &arg1se.post);
2400
2401           /* See if we were given two arguments.  */
2402           if (arg->next == NULL)
2403             /* Only given one arg so generate a null and do a
2404                not-equal comparison against the first arg.  */
2405             se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2406                                     fold_convert (TREE_TYPE (arg1se.expr),
2407                                                   null_pointer_node));
2408           else
2409             {
2410               tree eq_expr;
2411               tree not_null_expr;
2412
2413               /* Given two arguments so build the arg2se from second arg.  */
2414               gfc_init_se (&arg2se, NULL);
2415               gfc_conv_expr (&arg2se, arg->next->expr);
2416               gfc_add_block_to_block (&se->pre, &arg2se.pre);
2417               gfc_add_block_to_block (&se->post, &arg2se.post);
2418
2419               /* Generate test to compare that the two args are equal.  */
2420               eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2421                                      arg1se.expr, arg2se.expr);
2422               /* Generate test to ensure that the first arg is not null.  */
2423               not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2424                                            arg1se.expr, null_pointer_node);
2425
2426               /* Finally, the generated test must check that both arg1 is not
2427                  NULL and that it is equal to the second arg.  */
2428               se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2429                                       not_null_expr, eq_expr);
2430             }
2431
2432           return 0;
2433         }
2434     }
2435
2436   if (se->ss != NULL)
2437     {
2438       if (!sym->attr.elemental)
2439         {
2440           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2441           if (se->ss->useflags)
2442             {
2443               gcc_assert (gfc_return_by_reference (sym)
2444                       && sym->result->attr.dimension);
2445               gcc_assert (se->loop != NULL);
2446
2447               /* Access the previously obtained result.  */
2448               gfc_conv_tmp_array_ref (se);
2449               gfc_advance_se_ss_chain (se);
2450               return 0;
2451             }
2452         }
2453       info = &se->ss->data.info;
2454     }
2455   else
2456     info = NULL;
2457
2458   gfc_init_block (&post);
2459   gfc_init_interface_mapping (&mapping);
2460   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2461                                   && sym->ts.cl->length
2462                                   && sym->ts.cl->length->expr_type
2463                                                 != EXPR_CONSTANT)
2464                               || sym->attr.dimension);
2465   formal = sym->formal;
2466   /* Evaluate the arguments.  */
2467   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2468     {
2469       e = arg->expr;
2470       fsym = formal ? formal->sym : NULL;
2471       parm_kind = MISSING;
2472       if (e == NULL)
2473         {
2474
2475           if (se->ignore_optional)
2476             {
2477               /* Some intrinsics have already been resolved to the correct
2478                  parameters.  */
2479               continue;
2480             }
2481           else if (arg->label)
2482             {
2483               has_alternate_specifier = 1;
2484               continue;
2485             }
2486           else
2487             {
2488               /* Pass a NULL pointer for an absent arg.  */
2489               gfc_init_se (&parmse, NULL);
2490               parmse.expr = null_pointer_node;
2491               if (arg->missing_arg_type == BT_CHARACTER)
2492                 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2493             }
2494         }
2495       else if (se->ss && se->ss->useflags)
2496         {
2497           /* An elemental function inside a scalarized loop.  */
2498           gfc_init_se (&parmse, se);
2499           gfc_conv_expr_reference (&parmse, e);
2500           parm_kind = ELEMENTAL;
2501         }
2502       else
2503         {
2504           /* A scalar or transformational function.  */
2505           gfc_init_se (&parmse, NULL);
2506           argss = gfc_walk_expr (e);
2507
2508           if (argss == gfc_ss_terminator)
2509             {
2510               if (fsym && fsym->attr.value)
2511                 {
2512                   if (fsym->ts.type == BT_CHARACTER
2513                       && fsym->ts.is_c_interop
2514                       && fsym->ns->proc_name != NULL
2515                       && fsym->ns->proc_name->attr.is_bind_c)
2516                     {
2517                       parmse.expr = NULL;
2518                       gfc_conv_scalar_char_value (fsym, &parmse, &e);
2519                       if (parmse.expr == NULL)
2520                         gfc_conv_expr (&parmse, e);
2521                     }
2522                   else
2523                     gfc_conv_expr (&parmse, e);
2524                 }
2525               else if (arg->name && arg->name[0] == '%')
2526                 /* Argument list functions %VAL, %LOC and %REF are signalled
2527                    through arg->name.  */
2528                 conv_arglist_function (&parmse, arg->expr, arg->name);
2529               else if ((e->expr_type == EXPR_FUNCTION)
2530                           && e->symtree->n.sym->attr.pointer
2531                           && fsym && fsym->attr.target)
2532                 {
2533                   gfc_conv_expr (&parmse, e);
2534                   parmse.expr = build_fold_addr_expr (parmse.expr);
2535                 }
2536               else
2537                 {
2538                   gfc_conv_expr_reference (&parmse, e);
2539                   if (fsym && e->expr_type != EXPR_NULL
2540                       && ((fsym->attr.pointer
2541                            && fsym->attr.flavor != FL_PROCEDURE)
2542                           || fsym->attr.proc_pointer))
2543                     {
2544                       /* Scalar pointer dummy args require an extra level of
2545                          indirection. The null pointer already contains
2546                          this level of indirection.  */
2547                       parm_kind = SCALAR_POINTER;
2548                       parmse.expr = build_fold_addr_expr (parmse.expr);
2549                     }
2550                 }
2551             }
2552           else
2553             {
2554               /* If the procedure requires an explicit interface, the actual
2555                  argument is passed according to the corresponding formal
2556                  argument.  If the corresponding formal argument is a POINTER,
2557                  ALLOCATABLE or assumed shape, we do not use g77's calling
2558                  convention, and pass the address of the array descriptor
2559                  instead. Otherwise we use g77's calling convention.  */
2560               int f;
2561               f = (fsym != NULL)
2562                   && !(fsym->attr.pointer || fsym->attr.allocatable)
2563                   && fsym->as->type != AS_ASSUMED_SHAPE;
2564               f = f || !sym->attr.always_explicit;
2565
2566               if (e->expr_type == EXPR_VARIABLE
2567                     && is_subref_array (e))
2568                 /* The actual argument is a component reference to an
2569                    array of derived types.  In this case, the argument
2570                    is converted to a temporary, which is passed and then
2571                    written back after the procedure call.  */
2572                 gfc_conv_subref_array_arg (&parmse, e, f,
2573                         fsym ? fsym->attr.intent : INTENT_INOUT);
2574               else
2575                 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2576                                           sym->name);
2577
2578               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2579                  allocated on entry, it must be deallocated.  */
2580               if (fsym && fsym->attr.allocatable
2581                   && fsym->attr.intent == INTENT_OUT)
2582                 {
2583                   tmp = build_fold_indirect_ref (parmse.expr);
2584                   tmp = gfc_trans_dealloc_allocated (tmp);
2585                   gfc_add_expr_to_block (&se->pre, tmp);
2586                 }
2587
2588             }
2589         }
2590
2591       /* The case with fsym->attr.optional is that of a user subroutine
2592          with an interface indicating an optional argument.  When we call
2593          an intrinsic subroutine, however, fsym is NULL, but we might still
2594          have an optional argument, so we proceed to the substitution
2595          just in case.  */
2596       if (e && (fsym == NULL || fsym->attr.optional))
2597         {
2598           /* If an optional argument is itself an optional dummy argument,
2599              check its presence and substitute a null if absent.  */
2600           if (e->expr_type == EXPR_VARIABLE
2601               && e->symtree->n.sym->attr.optional)
2602             gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2603                                     e->representation.length);
2604         }
2605
2606       if (fsym && e)
2607         {
2608           /* Obtain the character length of an assumed character length
2609              length procedure from the typespec.  */
2610           if (fsym->ts.type == BT_CHARACTER
2611               && parmse.string_length == NULL_TREE
2612               && e->ts.type == BT_PROCEDURE
2613               && e->symtree->n.sym->ts.type == BT_CHARACTER
2614               && e->symtree->n.sym->ts.cl->length != NULL)
2615             {
2616               gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2617               parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2618             }
2619         }
2620
2621       if (fsym && need_interface_mapping && e)
2622         gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2623
2624       gfc_add_block_to_block (&se->pre, &parmse.pre);
2625       gfc_add_block_to_block (&post, &parmse.post);
2626
2627       /* Allocated allocatable components of derived types must be
2628          deallocated for INTENT(OUT) dummy arguments and non-variable
2629          scalars.  Non-variable arrays are dealt with in trans-array.c
2630          (gfc_conv_array_parameter).  */
2631       if (e && e->ts.type == BT_DERIVED
2632             && e->ts.derived->attr.alloc_comp
2633             && ((formal && formal->sym->attr.intent == INTENT_OUT)
2634                    ||
2635                 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2636         {
2637           int parm_rank;
2638           tmp = build_fold_indirect_ref (parmse.expr);
2639           parm_rank = e->rank;
2640           switch (parm_kind)
2641             {
2642             case (ELEMENTAL):
2643             case (SCALAR):
2644               parm_rank = 0;
2645               break;
2646
2647             case (SCALAR_POINTER):
2648               tmp = build_fold_indirect_ref (tmp);
2649               break;
2650             case (ARRAY):
2651               tmp = parmse.expr;
2652               break;
2653             }
2654
2655           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2656           if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2657             tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2658                             tmp, build_empty_stmt ());
2659
2660           if (e->expr_type != EXPR_VARIABLE)
2661             /* Don't deallocate non-variables until they have been used.  */
2662             gfc_add_expr_to_block (&se->post, tmp);
2663           else
2664             {
2665               gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2666               gfc_add_expr_to_block (&se->pre, tmp);
2667             }
2668         }
2669
2670       /* Character strings are passed as two parameters, a length and a
2671          pointer - except for Bind(c) which only passes the pointer.  */
2672       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2673         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2674
2675       arglist = gfc_chainon_list (arglist, parmse.expr);
2676     }
2677   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2678
2679   ts = sym->ts;
2680   if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2681     {
2682       if (sym->ts.cl->length == NULL)
2683         {
2684           /* Assumed character length results are not allowed by 5.1.1.5 of the
2685              standard and are trapped in resolve.c; except in the case of SPREAD
2686              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
2687              we take the character length of the first argument for the result.
2688              For dummies, we have to look through the formal argument list for
2689              this function and use the character length found there.*/
2690           if (!sym->attr.dummy)
2691             cl.backend_decl = TREE_VALUE (stringargs);
2692           else
2693             {
2694               formal = sym->ns->proc_name->formal;
2695               for (; formal; formal = formal->next)
2696                 if (strcmp (formal->sym->name, sym->name) == 0)
2697                   cl.backend_decl = formal->sym->ts.cl->backend_decl;
2698             }
2699         }
2700         else
2701         {
2702           tree tmp;
2703
2704           /* Calculate the length of the returned string.  */
2705           gfc_init_se (&parmse, NULL);
2706           if (need_interface_mapping)
2707             gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2708           else
2709             gfc_conv_expr (&parmse, sym->ts.cl->length);
2710           gfc_add_block_to_block (&se->pre, &parmse.pre);
2711           gfc_add_block_to_block (&se->post, &parmse.post);
2712
2713           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2714           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2715                              build_int_cst (gfc_charlen_type_node, 0));
2716           cl.backend_decl = tmp;
2717         }
2718
2719       /* Set up a charlen structure for it.  */
2720       cl.next = NULL;
2721       cl.length = NULL;
2722       ts.cl = &cl;
2723
2724       len = cl.backend_decl;
2725     }
2726
2727   byref = gfc_return_by_reference (sym);
2728   if (byref)
2729     {
2730       if (se->direct_byref)
2731         {
2732           /* Sometimes, too much indirection can be applied; e.g. for
2733              function_result = array_valued_recursive_function.  */
2734           if (TREE_TYPE (TREE_TYPE (se->expr))
2735                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2736                 && GFC_DESCRIPTOR_TYPE_P
2737                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2738             se->expr = build_fold_indirect_ref (se->expr);
2739
2740           retargs = gfc_chainon_list (retargs, se->expr);
2741         }
2742       else if (sym->result->attr.dimension)
2743         {
2744           gcc_assert (se->loop && info);
2745
2746           /* Set the type of the array.  */
2747           tmp = gfc_typenode_for_spec (&ts);
2748           info->dimen = se->loop->dimen;
2749
2750           /* Evaluate the bounds of the result, if known.  */
2751           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2752
2753           /* Create a temporary to store the result.  In case the function
2754              returns a pointer, the temporary will be a shallow copy and
2755              mustn't be deallocated.  */
2756           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2757           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2758                                        false, !sym->attr.pointer, callee_alloc,
2759                                        &se->ss->expr->where);
2760
2761           /* Pass the temporary as the first argument.  */
2762           tmp = info->descriptor;
2763           tmp = build_fold_addr_expr (tmp);
2764           retargs = gfc_chainon_list (retargs, tmp);
2765         }
2766       else if (ts.type == BT_CHARACTER)
2767         {
2768           /* Pass the string length.  */
2769           type = gfc_get_character_type (ts.kind, ts.cl);
2770           type = build_pointer_type (type);
2771
2772           /* Return an address to a char[0:len-1]* temporary for
2773              character pointers.  */
2774           if (sym->attr.pointer || sym->attr.allocatable)
2775             {
2776               var = gfc_create_var (type, "pstr");
2777
2778               /* Provide an address expression for the function arguments.  */
2779               var = build_fold_addr_expr (var);
2780             }
2781           else
2782             var = gfc_conv_string_tmp (se, type, len);
2783
2784           retargs = gfc_chainon_list (retargs, var);
2785         }
2786       else
2787         {
2788           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2789
2790           type = gfc_get_complex_type (ts.kind);
2791           var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2792           retargs = gfc_chainon_list (retargs, var);
2793         }
2794
2795       /* Add the string length to the argument list.  */
2796       if (ts.type == BT_CHARACTER)
2797         retargs = gfc_chainon_list (retargs, len);
2798     }
2799   gfc_free_interface_mapping (&mapping);
2800
2801   /* Add the return arguments.  */
2802   arglist = chainon (retargs, arglist);
2803
2804   /* Add the hidden string length parameters to the arguments.  */
2805   arglist = chainon (arglist, stringargs);
2806
2807   /* We may want to append extra arguments here.  This is used e.g. for
2808      calls to libgfortran_matmul_??, which need extra information.  */
2809   if (append_args != NULL_TREE)
2810     arglist = chainon (arglist, append_args);
2811
2812   /* Generate the actual call.  */
2813   gfc_conv_function_val (se, sym);
2814
2815   /* If there are alternate return labels, function type should be
2816      integer.  Can't modify the type in place though, since it can be shared
2817      with other functions.  For dummy arguments, the typing is done to
2818      to this result, even if it has to be repeated for each call.  */
2819   if (has_alternate_specifier
2820       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2821     {
2822       if (!sym->attr.dummy)
2823         {
2824           TREE_TYPE (sym->backend_decl)
2825                 = build_function_type (integer_type_node,
2826                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2827           se->expr = build_fold_addr_expr (sym->backend_decl);
2828         }
2829       else
2830         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2831     }
2832
2833   fntype = TREE_TYPE (TREE_TYPE (se->expr));
2834   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2835
2836   /* If we have a pointer function, but we don't want a pointer, e.g.
2837      something like
2838         x = f()
2839      where f is pointer valued, we have to dereference the result.  */
2840   if (!se->want_pointer && !byref && sym->attr.pointer)
2841     se->expr = build_fold_indirect_ref (se->expr);
2842
2843   /* f2c calling conventions require a scalar default real function to
2844      return a double precision result.  Convert this back to default
2845      real.  We only care about the cases that can happen in Fortran 77.
2846   */
2847   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2848       && sym->ts.kind == gfc_default_real_kind
2849       && !sym->attr.always_explicit)
2850     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2851
2852   /* A pure function may still have side-effects - it may modify its
2853      parameters.  */
2854   TREE_SIDE_EFFECTS (se->expr) = 1;
2855 #if 0
2856   if (!sym->attr.pure)
2857     TREE_SIDE_EFFECTS (se->expr) = 1;
2858 #endif
2859
2860   if (byref)
2861     {
2862       /* Add the function call to the pre chain.  There is no expression.  */
2863       gfc_add_expr_to_block (&se->pre, se->expr);
2864       se->expr = NULL_TREE;
2865
2866       if (!se->direct_byref)
2867         {
2868           if (sym->attr.dimension)
2869             {
2870               if (flag_bounds_check)
2871                 {
2872                   /* Check the data pointer hasn't been modified.  This would
2873                      happen in a function returning a pointer.  */
2874                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2875                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
2876                                      tmp, info->data);
2877                   gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
2878                                            gfc_msg_fault);
2879                 }
2880               se->expr = info->descriptor;
2881               /* Bundle in the string length.  */
2882               se->string_length = len;
2883             }
2884           else if (sym->ts.type == BT_CHARACTER)
2885             {
2886               /* Dereference for character pointer results.  */
2887               if (sym->attr.pointer || sym->attr.allocatable)
2888                 se->expr = build_fold_indirect_ref (var);
2889               else
2890                 se->expr = var;
2891
2892               se->string_length = len;
2893             }
2894           else
2895             {
2896               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2897               se->expr = build_fold_indirect_ref (var);
2898             }
2899         }
2900     }
2901
2902   /* Follow the function call with the argument post block.  */
2903   if (byref)
2904     gfc_add_block_to_block (&se->pre, &post);
2905   else
2906     gfc_add_block_to_block (&se->post, &post);
2907
2908   return has_alternate_specifier;
2909 }
2910
2911
2912 /* Fill a character string with spaces.  */
2913
2914 static tree
2915 fill_with_spaces (tree start, tree type, tree size)
2916 {
2917   stmtblock_t block, loop;
2918   tree i, el, exit_label, cond, tmp;
2919
2920   /* For a simple char type, we can call memset().  */
2921   if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
2922     return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
2923                             build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2924                                            lang_hooks.to_target_charset (' ')),
2925                             size);
2926
2927   /* Otherwise, we use a loop:
2928         for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
2929           *el = (type) ' ';
2930    */
2931
2932   /* Initialize variables.  */
2933   gfc_init_block (&block);
2934   i = gfc_create_var (sizetype, "i");
2935   gfc_add_modify (&block, i, fold_convert (sizetype, size));
2936   el = gfc_create_var (build_pointer_type (type), "el");
2937   gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
2938   exit_label = gfc_build_label_decl (NULL_TREE);
2939   TREE_USED (exit_label) = 1;
2940
2941
2942   /* Loop body.  */
2943   gfc_init_block (&loop);
2944
2945   /* Exit condition.  */
2946   cond = fold_build2 (LE_EXPR, boolean_type_node, i,
2947                       fold_convert (sizetype, integer_zero_node));
2948   tmp = build1_v (GOTO_EXPR, exit_label);
2949   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2950   gfc_add_expr_to_block (&loop, tmp);
2951
2952   /* Assignment.  */
2953   gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
2954                        build_int_cst (type,
2955                                       lang_hooks.to_target_charset (' ')));
2956
2957   /* Increment loop variables.  */
2958   gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
2959                                               TYPE_SIZE_UNIT (type)));
2960   gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
2961                                                TREE_TYPE (el), el,
2962                                                TYPE_SIZE_UNIT (type)));
2963
2964   /* Making the loop... actually loop!  */
2965   tmp = gfc_finish_block (&loop);
2966   tmp = build1_v (LOOP_EXPR, tmp);
2967   gfc_add_expr_to_block (&block, tmp);
2968
2969   /* The exit label.  */
2970   tmp = build1_v (LABEL_EXPR, exit_label);
2971   gfc_add_expr_to_block (&block, tmp);
2972
2973
2974   return gfc_finish_block (&block);
2975 }
2976
2977
2978 /* Generate code to copy a string.  */
2979
2980 void
2981 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2982                        int dkind, tree slength, tree src, int skind)
2983 {
2984   tree tmp, dlen, slen;
2985   tree dsc;
2986   tree ssc;
2987   tree cond;
2988   tree cond2;
2989   tree tmp2;
2990   tree tmp3;
2991   tree tmp4;
2992   tree chartype;
2993   stmtblock_t tempblock;
2994
2995   gcc_assert (dkind == skind);
2996
2997   if (slength != NULL_TREE)
2998     {
2999       slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3000       ssc = string_to_single_character (slen, src, skind);
3001     }
3002   else
3003     {
3004       slen = build_int_cst (size_type_node, 1);
3005       ssc =  src;
3006     }
3007
3008   if (dlength != NULL_TREE)
3009     {
3010       dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3011       dsc = string_to_single_character (slen, dest, dkind);
3012     }
3013   else
3014     {
3015       dlen = build_int_cst (size_type_node, 1);
3016       dsc =  dest;
3017     }
3018
3019   if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3020     ssc = string_to_single_character (slen, src, skind);
3021   if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3022     dsc = string_to_single_character (dlen, dest, dkind);
3023
3024
3025   /* Assign directly if the types are compatible.  */
3026   if (dsc != NULL_TREE && ssc != NULL_TREE
3027       && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3028     {
3029       gfc_add_modify (block, dsc, ssc);
3030       return;
3031     }
3032
3033   /* Do nothing if the destination length is zero.  */
3034   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3035                       build_int_cst (size_type_node, 0));
3036
3037   /* The following code was previously in _gfortran_copy_string:
3038
3039        // The two strings may overlap so we use memmove.
3040        void
3041        copy_string (GFC_INTEGER_4 destlen, char * dest,
3042                     GFC_INTEGER_4 srclen, const char * src)
3043        {
3044          if (srclen >= destlen)
3045            {
3046              // This will truncate if too long.
3047              memmove (dest, src, destlen);
3048            }
3049          else
3050            {
3051              memmove (dest, src, srclen);
3052              // Pad with spaces.
3053              memset (&dest[srclen], ' ', destlen - srclen);
3054            }
3055        }
3056
3057      We're now doing it here for better optimization, but the logic
3058      is the same.  */
3059
3060   /* For non-default character kinds, we have to multiply the string
3061      length by the base type size.  */
3062   chartype = gfc_get_char_type (dkind);
3063   slen = fold_build2 (MULT_EXPR, size_type_node, slen,
3064                       TYPE_SIZE_UNIT (chartype));
3065   dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
3066                       TYPE_SIZE_UNIT (chartype));
3067
3068   if (dlength)
3069     dest = fold_convert (pvoid_type_node, dest);
3070   else
3071     dest = gfc_build_addr_expr (pvoid_type_node, dest);
3072
3073   if (slength)
3074     src = fold_convert (pvoid_type_node, src);
3075   else
3076     src = gfc_build_addr_expr (pvoid_type_node, src);
3077
3078   /* Truncate string if source is too long.  */
3079   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3080   tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3081                           3, dest, src, dlen);
3082
3083   /* Else copy and pad with spaces.  */
3084   tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3085                           3, dest, src, slen);
3086
3087   tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3088                       fold_convert (sizetype, slen));
3089   tmp4 = fill_with_spaces (tmp4, chartype,
3090                            fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3091                                         dlen, slen));
3092
3093   gfc_init_block (&tempblock);
3094   gfc_add_expr_to_block (&tempblock, tmp3);
3095   gfc_add_expr_to_block (&tempblock, tmp4);
3096   tmp3 = gfc_finish_block (&tempblock);
3097
3098   /* The whole copy_string function is there.  */
3099   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3100   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3101   gfc_add_expr_to_block (block, tmp);
3102 }
3103
3104
3105 /* Translate a statement function.
3106    The value of a statement function reference is obtained by evaluating the
3107    expression using the values of the actual arguments for the values of the
3108    corresponding dummy arguments.  */
3109
3110 static void
3111 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3112 {
3113   gfc_symbol *sym;
3114   gfc_symbol *fsym;
3115   gfc_formal_arglist *fargs;
3116   gfc_actual_arglist *args;
3117   gfc_se lse;
3118   gfc_se rse;
3119   gfc_saved_var *saved_vars;
3120   tree *temp_vars;
3121   tree type;
3122   tree tmp;
3123   int n;
3124
3125   sym = expr->symtree->n.sym;
3126   args = expr->value.function.actual;
3127   gfc_init_se (&lse, NULL);
3128   gfc_init_se (&rse, NULL);
3129
3130   n = 0;
3131   for (fargs = sym->formal; fargs; fargs = fargs->next)
3132     n++;
3133   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3134   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3135
3136   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3137     {
3138       /* Each dummy shall be specified, explicitly or implicitly, to be
3139          scalar.  */
3140       gcc_assert (fargs->sym->attr.dimension == 0);
3141       fsym = fargs->sym;
3142
3143       /* Create a temporary to hold the value.  */
3144       type = gfc_typenode_for_spec (&fsym->ts);
3145       temp_vars[n] = gfc_create_var (type, fsym->name);
3146
3147       if (fsym->ts.type == BT_CHARACTER)
3148         {
3149           /* Copy string arguments.  */
3150           tree arglen;
3151
3152           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3153                       && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3154
3155           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3156           tmp = gfc_build_addr_expr (build_pointer_type (type),
3157                                      temp_vars[n]);
3158
3159           gfc_conv_expr (&rse, args->expr);
3160           gfc_conv_string_parameter (&rse);
3161           gfc_add_block_to_block (&se->pre, &lse.pre);
3162           gfc_add_block_to_block (&se->pre, &rse.pre);
3163
3164           gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3165                                  rse.string_length, rse.expr, fsym->ts.kind);
3166           gfc_add_block_to_block (&se->pre, &lse.post);
3167           gfc_add_block_to_block (&se->pre, &rse.post);
3168         }
3169       else
3170         {
3171           /* For everything else, just evaluate the expression.  */
3172           gfc_conv_expr (&lse, args->expr);
3173
3174           gfc_add_block_to_block (&se->pre, &lse.pre);
3175           gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3176           gfc_add_block_to_block (&se->pre, &lse.post);
3177         }
3178
3179       args = args->next;
3180     }
3181
3182   /* Use the temporary variables in place of the real ones.  */
3183   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3184     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3185
3186   gfc_conv_expr (se, sym->value);
3187
3188   if (sym->ts.type == BT_CHARACTER)
3189     {
3190       gfc_conv_const_charlen (sym->ts.cl);
3191
3192       /* Force the expression to the correct length.  */
3193       if (!INTEGER_CST_P (se->string_length)
3194           || tree_int_cst_lt (se->string_length,
3195                               sym->ts.cl->backend_decl))
3196         {
3197           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3198           tmp = gfc_create_var (type, sym->name);
3199           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3200           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3201                                  sym->ts.kind, se->string_length, se->expr,
3202                                  sym->ts.kind);
3203           se->expr = tmp;
3204         }
3205       se->string_length = sym->ts.cl->backend_decl;
3206     }
3207
3208   /* Restore the original variables.  */
3209   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3210     gfc_restore_sym (fargs->sym, &saved_vars[n]);
3211   gfc_free (saved_vars);
3212 }
3213
3214
3215 /* Translate a function expression.  */
3216
3217 static void
3218 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3219 {
3220   gfc_symbol *sym;
3221
3222   if (expr->value.function.isym)
3223     {
3224       gfc_conv_intrinsic_function (se, expr);
3225       return;
3226     }
3227
3228   /* We distinguish statement functions from general functions to improve
3229      runtime performance.  */
3230   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3231     {
3232       gfc_conv_statement_function (se, expr);
3233       return;
3234     }
3235
3236   /* expr.value.function.esym is the resolved (specific) function symbol for
3237      most functions.  However this isn't set for dummy procedures.  */
3238   sym = expr->value.function.esym;
3239   if (!sym)
3240     sym = expr->symtree->n.sym;
3241   gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3242 }
3243
3244
3245 static void
3246 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3247 {
3248   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3249   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3250
3251   gfc_conv_tmp_array_ref (se);
3252   gfc_advance_se_ss_chain (se);
3253 }
3254
3255
3256 /* Build a static initializer.  EXPR is the expression for the initial value.
3257    The other parameters describe the variable of the component being
3258    initialized. EXPR may be null.  */
3259
3260 tree
3261 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3262                       bool array, bool pointer)
3263 {
3264   gfc_se se;
3265
3266   if (!(expr || pointer))
3267     return NULL_TREE;
3268
3269   /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3270      (these are the only two iso_c_binding derived types that can be
3271      used as initialization expressions).  If so, we need to modify
3272      the 'expr' to be that for a (void *).  */
3273   if (expr != NULL && expr->ts.type == BT_DERIVED
3274       && expr->ts.is_iso_c && expr->ts.derived)
3275     {
3276       gfc_symbol *derived = expr->ts.derived;
3277
3278       expr = gfc_int_expr (0);
3279
3280       /* The derived symbol has already been converted to a (void *).  Use
3281          its kind.  */
3282       expr->ts.f90_type = derived->ts.f90_type;
3283       expr->ts.kind = derived->ts.kind;
3284     }
3285
3286   if (array)
3287     {
3288       /* Arrays need special handling.  */
3289       if (pointer)
3290         return gfc_build_null_descriptor (type);
3291       else
3292         return gfc_conv_array_initializer (type, expr);
3293     }
3294   else if (pointer)
3295     return fold_convert (type, null_pointer_node);
3296   else
3297     {
3298       switch (ts->type)
3299         {
3300         case BT_DERIVED:
3301           gfc_init_se (&se, NULL);
3302           gfc_conv_structure (&se, expr, 1);
3303           return se.expr;
3304
3305         case BT_CHARACTER:
3306           return gfc_conv_string_init (ts->cl->backend_decl,expr);
3307
3308         default:
3309           gfc_init_se (&se, NULL);
3310           gfc_conv_constant (&se, expr);
3311           return se.expr;
3312         }
3313     }
3314 }
3315
3316 static tree
3317 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3318 {
3319   gfc_se rse;
3320   gfc_se lse;
3321   gfc_ss *rss;
3322   gfc_ss *lss;
3323   stmtblock_t body;
3324   stmtblock_t block;
3325   gfc_loopinfo loop;
3326   int n;
3327   tree tmp;
3328
3329   gfc_start_block (&block);
3330
3331   /* Initialize the scalarizer.  */
3332   gfc_init_loopinfo (&loop);
3333
3334   gfc_init_se (&lse, NULL);
3335   gfc_init_se (&rse, NULL);
3336
3337   /* Walk the rhs.  */
3338   rss = gfc_walk_expr (expr);
3339   if (rss == gfc_ss_terminator)
3340     {
3341       /* The rhs is scalar.  Add a ss for the expression.  */
3342       rss = gfc_get_ss ();
3343       rss->next = gfc_ss_terminator;
3344       rss->type = GFC_SS_SCALAR;
3345       rss->expr = expr;
3346     }
3347
3348   /* Create a SS for the destination.  */
3349   lss = gfc_get_ss ();
3350   lss->type = GFC_SS_COMPONENT;
3351   lss->expr = NULL;
3352   lss->shape = gfc_get_shape (cm->as->rank);
3353   lss->next = gfc_ss_terminator;
3354   lss->data.info.dimen = cm->as->rank;
3355   lss->data.info.descriptor = dest;
3356   lss->data.info.data = gfc_conv_array_data (dest);
3357   lss->data.info.offset = gfc_conv_array_offset (dest);
3358   for (n = 0; n < cm->as->rank; n++)
3359     {
3360       lss->data.info.dim[n] = n;
3361       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3362       lss->data.info.stride[n] = gfc_index_one_node;
3363
3364       mpz_init (lss->shape[n]);
3365       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3366                cm->as->lower[n]->value.integer);
3367       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3368     }
3369
3370   /* Associate the SS with the loop.  */
3371   gfc_add_ss_to_loop (&loop, lss);
3372   gfc_add_ss_to_loop (&loop, rss);
3373
3374   /* Calculate the bounds of the scalarization.  */
3375   gfc_conv_ss_startstride (&loop);
3376
3377   /* Setup the scalarizing loops.  */
3378   gfc_conv_loop_setup (&loop, &expr->where);
3379
3380   /* Setup the gfc_se structures.  */
3381   gfc_copy_loopinfo_to_se (&lse, &loop);
3382   gfc_copy_loopinfo_to_se (&rse, &loop);
3383
3384   rse.ss = rss;
3385   gfc_mark_ss_chain_used (rss, 1);
3386   lse.ss = lss;
3387   gfc_mark_ss_chain_used (lss, 1);
3388
3389   /* Start the scalarized loop body.  */
3390   gfc_start_scalarized_body (&loop, &body);
3391
3392   gfc_conv_tmp_array_ref (&lse);
3393   if (cm->ts.type == BT_CHARACTER)
3394     lse.string_length = cm->ts.cl->backend_decl;
3395
3396   gfc_conv_expr (&rse, expr);
3397
3398   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3399   gfc_add_expr_to_block (&body, tmp);
3400
3401   gcc_assert (rse.ss == gfc_ss_terminator);
3402
3403   /* Generate the copying loops.  */
3404   gfc_trans_scalarizing_loops (&loop, &body);
3405
3406   /* Wrap the whole thing up.  */
3407   gfc_add_block_to_block (&block, &loop.pre);
3408   gfc_add_block_to_block (&block, &loop.post);
3409
3410   for (n = 0; n < cm->as->rank; n++)
3411     mpz_clear (lss->shape[n]);
3412   gfc_free (lss->shape);
3413
3414   gfc_cleanup_loop (&loop);
3415
3416   return gfc_finish_block (&block);
3417 }
3418
3419
3420 /* Assign a single component of a derived type constructor.  */
3421
3422 static tree
3423 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3424 {
3425   gfc_se se;
3426   gfc_se lse;
3427   gfc_ss *rss;
3428   stmtblock_t block;
3429   tree tmp;
3430   tree offset;
3431   int n;
3432
3433   gfc_start_block (&block);
3434
3435   if (cm->pointer)
3436     {
3437       gfc_init_se (&se, NULL);
3438       /* Pointer component.  */
3439       if (cm->dimension)
3440         {
3441           /* Array pointer.  */
3442           if (expr->expr_type == EXPR_NULL)
3443             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3444           else
3445             {
3446               rss = gfc_walk_expr (expr);
3447               se.direct_byref = 1;
3448               se.expr = dest;
3449               gfc_conv_expr_descriptor (&se, expr, rss);
3450               gfc_add_block_to_block (&block, &se.pre);
3451               gfc_add_block_to_block (&block, &se.post);
3452             }
3453         }
3454       else
3455         {
3456           /* Scalar pointers.  */
3457           se.want_pointer = 1;
3458           gfc_conv_expr (&se, expr);
3459           gfc_add_block_to_block (&block, &se.pre);
3460           gfc_add_modify (&block, dest,
3461                                fold_convert (TREE_TYPE (dest), se.expr));
3462           gfc_add_block_to_block (&block, &se.post);
3463         }
3464     }
3465   else if (cm->dimension)
3466     {
3467       if (cm->allocatable && expr->expr_type == EXPR_NULL)
3468         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3469       else if (cm->allocatable)
3470         {
3471           tree tmp2;
3472
3473           gfc_init_se (&se, NULL);
3474
3475           rss = gfc_walk_expr (expr);
3476           se.want_pointer = 0;
3477           gfc_conv_expr_descriptor (&se, expr, rss);
3478           gfc_add_block_to_block (&block, &se.pre);
3479
3480           tmp = fold_convert (TREE_TYPE (dest), se.expr);
3481           gfc_add_modify (&block, dest, tmp);
3482
3483           if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3484             tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3485                                        cm->as->rank);
3486           else
3487             tmp = gfc_duplicate_allocatable (dest, se.expr,
3488                                              TREE_TYPE(cm->backend_decl),
3489                                              cm->as->rank);
3490
3491           gfc_add_expr_to_block (&block, tmp);
3492
3493           gfc_add_block_to_block (&block, &se.post);
3494           gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3495
3496           /* Shift the lbound and ubound of temporaries to being unity, rather
3497              than zero, based.  Calculate the offset for all cases.  */
3498           offset = gfc_conv_descriptor_offset (dest);
3499           gfc_add_modify (&block, offset, gfc_index_zero_node);
3500           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3501           for (n = 0; n < expr->rank; n++)
3502             {
3503               if (expr->expr_type != EXPR_VARIABLE
3504                     && expr->expr_type != EXPR_CONSTANT)
3505                 {
3506                   tree span;
3507                   tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3508                   span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3509                             gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3510                   gfc_add_modify (&block, tmp,
3511                                        fold_build2 (PLUS_EXPR,
3512                                                     gfc_array_index_type,
3513                                                     span, gfc_index_one_node));
3514                   tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3515                   gfc_add_modify (&block, tmp, gfc_index_one_node);
3516                 }
3517               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3518                                  gfc_conv_descriptor_lbound (dest,
3519                                                              gfc_rank_cst[n]),
3520                                  gfc_conv_descriptor_stride (dest,
3521                                                              gfc_rank_cst[n]));
3522               gfc_add_modify (&block, tmp2, tmp);
3523               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3524               gfc_add_modify (&block, offset, tmp);
3525             }
3526         }
3527       else
3528         {
3529           tmp = gfc_trans_subarray_assign (dest, cm, expr);
3530           gfc_add_expr_to_block (&block, tmp);
3531         }
3532     }
3533   else if (expr->ts.type == BT_DERIVED)
3534     {
3535       if (expr->expr_type != EXPR_STRUCTURE)
3536         {
3537           gfc_init_se (&se, NULL);
3538           gfc_conv_expr (&se, expr);
3539           gfc_add_modify (&block, dest,
3540                                fold_convert (TREE_TYPE (dest), se.expr));
3541         }
3542       else
3543         {
3544           /* Nested constructors.  */
3545           tmp = gfc_trans_structure_assign (dest, expr);
3546           gfc_add_expr_to_block (&block, tmp);
3547         }
3548     }
3549   else
3550     {
3551       /* Scalar component.  */
3552       gfc_init_se (&se, NULL);
3553       gfc_init_se (&lse, NULL);
3554
3555       gfc_conv_expr (&se, expr);
3556       if (cm->ts.type == BT_CHARACTER)
3557         lse.string_length = cm->ts.cl->backend_decl;
3558       lse.expr = dest;
3559       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3560       gfc_add_expr_to_block (&block, tmp);
3561     }
3562   return gfc_finish_block (&block);
3563 }
3564
3565 /* Assign a derived type constructor to a variable.  */
3566
3567 static tree
3568 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3569 {
3570   gfc_constructor *c;
3571   gfc_component *cm;
3572   stmtblock_t block;
3573   tree field;
3574   tree tmp;
3575
3576   gfc_start_block (&block);
3577   cm = expr->ts.derived->components;
3578   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3579     {
3580       /* Skip absent members in default initializers.  */
3581       if (!c->expr)
3582         continue;
3583
3584       /* Update the type/kind of the expression if it represents either
3585          C_NULL_PTR or C_NULL_FUNPTR.  This is done here because this may
3586          be the first place reached for initializing output variables that
3587          have components of type C_PTR/C_FUNPTR that are initialized.  */
3588       if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3589           && c->expr->ts.derived->attr.is_iso_c)
3590         {
3591           c->expr->expr_type = EXPR_NULL;
3592           c->expr->ts.type = c->expr->ts.derived->ts.type;
3593           c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3594           c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3595         }
3596
3597       field = cm->backend_decl;
3598       tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3599                          dest, field, NULL_TREE);
3600       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3601       gfc_add_expr_to_block (&block, tmp);
3602     }
3603   return gfc_finish_block (&block);
3604 }
3605
3606 /* Build an expression for a constructor. If init is nonzero then
3607    this is part of a static variable initializer.  */
3608
3609 void
3610 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3611 {
3612   gfc_constructor *c;
3613   gfc_component *cm;
3614   tree val;
3615   tree type;
3616   tree tmp;
3617   VEC(constructor_elt,gc) *v = NULL;
3618
3619   gcc_assert (se->ss == NULL);
3620   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3621   type = gfc_typenode_for_spec (&expr->ts);
3622
3623   if (!init)
3624     {
3625       /* Create a temporary variable and fill it in.  */
3626       se->expr = gfc_create_var (type, expr->ts.derived->name);
3627       tmp = gfc_trans_structure_assign (se->expr, expr);
3628       gfc_add_expr_to_block (&se->pre, tmp);
3629       return;
3630     }
3631
3632   cm = expr->ts.derived->components;
3633
3634   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3635     {
3636       /* Skip absent members in default initializers and allocatable
3637          components.  Although the latter have a default initializer
3638          of EXPR_NULL,... by default, the static nullify is not needed
3639          since this is done every time we come into scope.  */
3640       if (!c->expr || cm->allocatable)
3641         continue;
3642
3643       val = gfc_conv_initializer (c->expr, &cm->ts,
3644           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3645
3646       /* Append it to the constructor list.  */
3647       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3648     }
3649   se->expr = build_constructor (type, v);
3650   if (init)
3651     TREE_CONSTANT (se->expr) = 1;
3652 }
3653
3654
3655 /* Translate a substring expression.  */
3656
3657 static void
3658 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3659 {
3660   gfc_ref *ref;
3661
3662   ref = expr->ref;
3663
3664   gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3665
3666   se->expr = gfc_build_wide_string_const (expr->ts.kind,
3667                                           expr->value.character.length,
3668                                           expr->value.character.string);
3669
3670   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3671   TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3672
3673   if (ref)
3674     gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3675 }
3676
3677
3678 /* Entry point for expression translation.  Evaluates a scalar quantity.
3679    EXPR is the expression to be translated, and SE is the state structure if
3680    called from within the scalarized.  */
3681
3682 void
3683 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3684 {
3685   if (se->ss && se->ss->expr == expr
3686       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3687     {
3688       /* Substitute a scalar expression evaluated outside the scalarization
3689          loop.  */
3690       se->expr = se->ss->data.scalar.expr;
3691       se->string_length = se->ss->string_length;
3692       gfc_advance_se_ss_chain (se);
3693       return;
3694     }
3695
3696   /* We need to convert the expressions for the iso_c_binding derived types.
3697      C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3698      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
3699      typespec for the C_PTR and C_FUNPTR symbols, which has already been
3700      updated to be an integer with a kind equal to the size of a (void *).  */
3701   if (expr->ts.type == BT_DERIVED && expr->ts.derived
3702       && expr->ts.derived->attr.is_iso_c)
3703     {
3704       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3705           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3706         {
3707           /* Set expr_type to EXPR_NULL, which will result in
3708              null_pointer_node being used below.  */
3709           expr->expr_type = EXPR_NULL;
3710         }
3711       else
3712         {
3713           /* Update the type/kind of the expression to be what the new
3714              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
3715           expr->ts.type = expr->ts.derived->ts.type;
3716           expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3717           expr->ts.kind = expr->ts.derived->ts.kind;
3718         }
3719     }
3720
3721   switch (expr->expr_type)
3722     {
3723     case EXPR_OP:
3724       gfc_conv_expr_op (se, expr);
3725       break;
3726
3727     case EXPR_FUNCTION:
3728       gfc_conv_function_expr (se, expr);
3729       break;
3730
3731     case EXPR_CONSTANT:
3732       gfc_conv_constant (se, expr);
3733       break;
3734
3735     case EXPR_VARIABLE:
3736       gfc_conv_variable (se, expr);
3737       break;
3738
3739     case EXPR_NULL:
3740       se->expr = null_pointer_node;
3741       break;
3742
3743     case EXPR_SUBSTRING:
3744       gfc_conv_substring_expr (se, expr);
3745       break;
3746
3747     case EXPR_STRUCTURE:
3748       gfc_conv_structure (se, expr, 0);
3749       break;
3750
3751     case EXPR_ARRAY:
3752       gfc_conv_array_constructor_expr (se, expr);
3753       break;
3754
3755     default:
3756       gcc_unreachable ();
3757       break;
3758     }
3759 }
3760
3761 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3762    of an assignment.  */
3763 void
3764 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3765 {
3766   gfc_conv_expr (se, expr);
3767   /* All numeric lvalues should have empty post chains.  If not we need to
3768      figure out a way of rewriting an lvalue so that it has no post chain.  */
3769   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3770 }
3771
3772 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3773    numeric expressions.  Used for scalar values where inserting cleanup code
3774    is inconvenient.  */
3775 void
3776 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3777 {
3778   tree val;
3779
3780   gcc_assert (expr->ts.type != BT_CHARACTER);
3781   gfc_conv_expr (se, expr);
3782   if (se->post.head)
3783     {
3784       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3785       gfc_add_modify (&se->pre, val, se->expr);
3786       se->expr = val;
3787       gfc_add_block_to_block (&se->pre, &se->post);
3788     }
3789 }
3790
3791 /* Helper to translate an expression and convert it to a particular type.  */
3792 void
3793 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3794 {
3795   gfc_conv_expr_val (se, expr);
3796   se->expr = convert (type, se->expr);
3797 }
3798
3799
3800 /* Converts an expression so that it can be passed by reference.  Scalar
3801    values only.  */
3802
3803 void
3804 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3805 {
3806   tree var;
3807
3808   if (se->ss && se->ss->expr == expr
3809       && se->ss->type == GFC_SS_REFERENCE)
3810     {
3811       se->expr = se->ss->data.scalar.expr;
3812       se->string_length = se->ss->string_length;
3813       gfc_advance_se_ss_chain (se);
3814       return;
3815     }
3816
3817   if (expr->ts.type == BT_CHARACTER)
3818     {
3819       gfc_conv_expr (se, expr);
3820       gfc_conv_string_parameter (se);
3821       return;
3822     }
3823
3824   if (expr->expr_type == EXPR_VARIABLE)
3825     {
3826       se->want_pointer = 1;
3827       gfc_conv_expr (se, expr);
3828       if (se->post.head)
3829         {
3830           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3831           gfc_add_modify (&se->pre, var, se->expr);
3832           gfc_add_block_to_block (&se->pre, &se->post);
3833           se->expr = var;
3834         }
3835       return;
3836     }
3837
3838   if (expr->expr_type == EXPR_FUNCTION
3839         && expr->symtree->n.sym->attr.pointer
3840         && !expr->symtree->n.sym->attr.dimension)
3841     {
3842       se->want_pointer = 1;
3843       gfc_conv_expr (se, expr);
3844       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3845       gfc_add_modify (&se->pre, var, se->expr);
3846       se->expr = var;
3847       return;
3848     }
3849
3850
3851   gfc_conv_expr (se, expr);
3852
3853   /* Create a temporary var to hold the value.  */
3854   if (TREE_CONSTANT (se->expr))
3855     {
3856       tree tmp = se->expr;
3857       STRIP_TYPE_NOPS (tmp);
3858       var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3859       DECL_INITIAL (var) = tmp;
3860       TREE_STATIC (var) = 1;
3861       pushdecl (var);
3862     }
3863   else
3864     {
3865       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3866       gfc_add_modify (&se->pre, var, se->expr);
3867     }
3868   gfc_add_block_to_block (&se->pre, &se->post);
3869
3870   /* Take the address of that value.  */
3871   se->expr = build_fold_addr_expr (var);
3872 }
3873
3874
3875 tree
3876 gfc_trans_pointer_assign (gfc_code * code)
3877 {
3878   return gfc_trans_pointer_assignment (code->expr, code->expr2);
3879 }
3880
3881
3882 /* Generate code for a pointer assignment.  */
3883
3884 tree
3885 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3886 {
3887   gfc_se lse;
3888   gfc_se rse;
3889   gfc_ss *lss;
3890   gfc_ss *rss;
3891   stmtblock_t block;
3892   tree desc;
3893   tree tmp;
3894   tree decl;
3895
3896
3897   gfc_start_block (&block);
3898
3899   gfc_init_se (&lse, NULL);
3900
3901   lss = gfc_walk_expr (expr1);
3902   rss = gfc_walk_expr (expr2);
3903   if (lss == gfc_ss_terminator)
3904     {
3905       /* Scalar pointers.  */
3906       lse.want_pointer = 1;
3907       gfc_conv_expr (&lse, expr1);
3908       gcc_assert (rss == gfc_ss_terminator);
3909       gfc_init_se (&rse, NULL);
3910       rse.want_pointer = 1;
3911       gfc_conv_expr (&rse, expr2);
3912
3913       if (expr1->symtree->n.sym->attr.proc_pointer
3914           && expr1->symtree->n.sym->attr.dummy)
3915         lse.expr = build_fold_indirect_ref (lse.expr);
3916
3917       gfc_add_block_to_block (&block, &lse.pre);
3918       gfc_add_block_to_block (&block, &rse.pre);
3919       gfc_add_modify (&block, lse.expr,
3920                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3921       gfc_add_block_to_block (&block, &rse.post);
3922       gfc_add_block_to_block (&block, &lse.post);
3923     }
3924   else
3925     {
3926       /* Array pointer.  */
3927       gfc_conv_expr_descriptor (&lse, expr1, lss);
3928       switch (expr2->expr_type)
3929         {
3930         case EXPR_NULL:
3931           /* Just set the data pointer to null.  */
3932           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3933           break;
3934
3935         case EXPR_VARIABLE:
3936           /* Assign directly to the pointer's descriptor.  */
3937           lse.direct_byref = 1;
3938           gfc_conv_expr_descriptor (&lse, expr2, rss);
3939
3940           /* If this is a subreference array pointer assignment, use the rhs
3941              descriptor element size for the lhs span.  */
3942           if (expr1->symtree->n.sym->attr.subref_array_pointer)
3943             {
3944               decl = expr1->symtree->n.sym->backend_decl;
3945               gfc_init_se (&rse, NULL);
3946               rse.descriptor_only = 1;
3947               gfc_conv_expr (&rse, expr2);
3948               tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
3949               tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
3950               if (!INTEGER_CST_P (tmp))
3951                 gfc_add_block_to_block (&lse.post, &rse.pre);
3952               gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
3953             }
3954
3955           break;
3956
3957         default:
3958           /* Assign to a temporary descriptor and then copy that
3959              temporary to the pointer.  */
3960           desc = lse.expr;
3961           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3962
3963           lse.expr = tmp;
3964           lse.direct_byref = 1;
3965           gfc_conv_expr_descriptor (&lse, expr2, rss);
3966           gfc_add_modify (&lse.pre, desc, tmp);
3967           break;
3968         }
3969       gfc_add_block_to_block (&block, &lse.pre);
3970       gfc_add_block_to_block (&block, &lse.post);
3971     }
3972   return gfc_finish_block (&block);
3973 }
3974
3975
3976 /* Makes sure se is suitable for passing as a function string parameter.  */
3977 /* TODO: Need to check all callers of this function.  It may be abused.  */
3978
3979 void
3980 gfc_conv_string_parameter (gfc_se * se)
3981 {
3982   tree type;
3983
3984   if (TREE_CODE (se->expr) == STRING_CST)
3985     {
3986       type = TREE_TYPE (TREE_TYPE (se->expr));
3987       se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3988       return;
3989     }
3990
3991   if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
3992     {
3993       if (TREE_CODE (se->expr) != INDIRECT_REF)
3994         {
3995           type = TREE_TYPE (se->expr);
3996           se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3997         }
3998       else
3999         {
4000           type = gfc_get_character_type_len (gfc_default_character_kind,
4001                                              se->string_length);
4002           type = build_pointer_type (type);
4003           se->expr = gfc_build_addr_expr (type, se->expr);
4004         }
4005     }
4006
4007   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4008   gcc_assert (se->string_length
4009           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4010 }
4011
4012
4013 /* Generate code for assignment of scalar variables.  Includes character
4014    strings and derived types with allocatable components.  */
4015
4016 tree
4017 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4018                          bool l_is_temp, bool r_is_var)
4019 {
4020   stmtblock_t block;
4021   tree tmp;
4022   tree cond;
4023
4024   gfc_init_block (&block);
4025
4026   if (ts.type == BT_CHARACTER)
4027     {
4028       tree rlen = NULL;
4029       tree llen = NULL;
4030
4031       if (lse->string_length != NULL_TREE)
4032         {
4033           gfc_conv_string_parameter (lse);
4034           gfc_add_block_to_block (&block, &lse->pre);
4035           llen = lse->string_length;
4036         }
4037
4038       if (rse->string_length != NULL_TREE)
4039         {
4040           gcc_assert (rse->string_length != NULL_TREE);
4041           gfc_conv_string_parameter (rse);
4042           gfc_add_block_to_block (&block, &rse->pre);
4043           rlen = rse->string_length;
4044         }
4045
4046       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4047                              rse->expr, ts.kind);
4048     }
4049   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4050     {
4051       cond = NULL_TREE;
4052
4053       /* Are the rhs and the lhs the same?  */
4054       if (r_is_var)
4055         {
4056           cond = fold_build2 (EQ_EXPR, boolean_type_node,
4057                               build_fold_addr_expr (lse->expr),
4058                               build_fold_addr_expr (rse->expr));
4059           cond = gfc_evaluate_now (cond, &lse->pre);
4060         }
4061
4062       /* Deallocate the lhs allocated components as long as it is not
4063          the same as the rhs.  This must be done following the assignment
4064          to prevent deallocating data that could be used in the rhs
4065          expression.  */
4066       if (!l_is_temp)
4067         {
4068           tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4069           tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4070           if (r_is_var)
4071             tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4072           gfc_add_expr_to_block (&lse->post, tmp);
4073         }
4074
4075       gfc_add_block_to_block (&block, &rse->pre);
4076       gfc_add_block_to_block (&block, &lse->pre);
4077
4078       gfc_add_modify (&block, lse->expr,
4079                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
4080
4081       /* Do a deep copy if the rhs is a variable, if it is not the
4082          same as the lhs.  */
4083       if (r_is_var)
4084         {
4085           tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4086           tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4087           gfc_add_expr_to_block (&block, tmp);
4088         }
4089     }
4090   else
4091     {
4092       gfc_add_block_to_block (&block, &lse->pre);
4093       gfc_add_block_to_block (&block, &rse->pre);
4094
4095       gfc_add_modify (&block, lse->expr,
4096                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
4097     }
4098
4099   gfc_add_block_to_block (&block, &lse->post);
4100   gfc_add_block_to_block (&block, &rse->post);
4101
4102   return gfc_finish_block (&block);
4103 }
4104
4105
4106 /* Try to translate array(:) = func (...), where func is a transformational
4107    array function, without using a temporary.  Returns NULL is this isn't the
4108    case.  */
4109
4110 static tree
4111 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4112 {
4113   gfc_se se;
4114   gfc_ss *ss;
4115   gfc_ref * ref;
4116   bool seen_array_ref;
4117
4118   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
4119   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4120     return NULL;
4121
4122   /* Elemental functions don't need a temporary anyway.  */
4123   if (expr2->value.function.esym != NULL
4124       && expr2->value.function.esym->attr.elemental)
4125     return NULL;
4126
4127   /* Fail if EXPR1 can't be expressed as a descriptor.  */
4128   if (gfc_ref_needs_temporary_p (expr1->ref))
4129     return NULL;
4130
4131   /* Functions returning pointers need temporaries.  */
4132   if (expr2->symtree->n.sym->attr.pointer
4133       || expr2->symtree->n.sym->attr.allocatable)
4134     return NULL;
4135
4136   /* Character array functions need temporaries unless the
4137      character lengths are the same.  */
4138   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4139     {
4140       if (expr1->ts.cl->length == NULL
4141             || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4142         return NULL;
4143
4144       if (expr2->ts.cl->length == NULL
4145             || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4146         return NULL;
4147
4148       if (mpz_cmp (expr1->ts.cl->length->value.integer,
4149                      expr2->ts.cl->length->value.integer) != 0)
4150         return NULL;
4151     }
4152
4153   /* Check that no LHS component references appear during an array
4154      reference. This is needed because we do not have the means to
4155      span any arbitrary stride with an array descriptor. This check
4156      is not needed for the rhs because the function result has to be
4157      a complete type.  */
4158   seen_array_ref = false;
4159   for (ref = expr1->ref; ref; ref = ref->next)
4160     {
4161       if (ref->type == REF_ARRAY)
4162         seen_array_ref= true;
4163       else if (ref->type == REF_COMPONENT && seen_array_ref)
4164         return NULL;
4165     }
4166
4167   /* Check for a dependency.  */
4168   if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4169                                    expr2->value.function.esym,
4170                                    expr2->value.function.actual))
4171     return NULL;
4172
4173   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4174      functions.  */
4175   gcc_assert (expr2->value.function.isym
4176               || (gfc_return_by_reference (expr2->value.function.esym)
4177               && expr2->value.function.esym->result->attr.dimension));
4178
4179   ss = gfc_walk_expr (expr1);
4180   gcc_assert (ss != gfc_ss_terminator);
4181   gfc_init_se (&se, NULL);
4182   gfc_start_block (&se.pre);
4183   se.want_pointer = 1;
4184
4185   gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
4186
4187   se.direct_byref = 1;
4188   se.ss = gfc_walk_expr (expr2);
4189   gcc_assert (se.ss != gfc_ss_terminator);
4190   gfc_conv_function_expr (&se, expr2);
4191   gfc_add_block_to_block (&se.pre, &se.post);
4192
4193   return gfc_finish_block (&se.pre);
4194 }
4195
4196 /* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
4197
4198 static bool
4199 is_zero_initializer_p (gfc_expr * expr)
4200 {
4201   if (expr->expr_type != EXPR_CONSTANT)
4202     return false;
4203
4204   /* We ignore constants with prescribed memory representations for now.  */
4205   if (expr->representation.string)
4206     return false;
4207
4208   switch (expr->ts.type)
4209     {
4210     case BT_INTEGER:
4211       return mpz_cmp_si (expr->value.integer, 0) == 0;
4212
4213     case BT_REAL:
4214       return mpfr_zero_p (expr->value.real)
4215              && MPFR_SIGN (expr->value.real) >= 0;
4216
4217     case BT_LOGICAL:
4218       return expr->value.logical == 0;
4219
4220     case BT_COMPLEX:
4221       return mpfr_zero_p (expr->value.complex.r)
4222              && MPFR_SIGN (expr->value.complex.r) >= 0
4223              && mpfr_zero_p (expr->value.complex.i)
4224              && MPFR_SIGN (expr->value.complex.i) >= 0;
4225
4226     default:
4227       break;
4228     }
4229   return false;
4230 }
4231
4232 /* Try to efficiently translate array(:) = 0.  Return NULL if this
4233    can't be done.  */
4234
4235 static tree
4236 gfc_trans_zero_assign (gfc_expr * expr)
4237 {
4238   tree dest, len, type;
4239   tree tmp;
4240   gfc_symbol *sym;
4241
4242   sym = expr->symtree->n.sym;
4243   dest = gfc_get_symbol_decl (sym);
4244
4245   type = TREE_TYPE (dest);
4246   if (POINTER_TYPE_P (type))
4247     type = TREE_TYPE (type);
4248   if (!GFC_ARRAY_TYPE_P (type))
4249     return NULL_TREE;
4250
4251   /* Determine the length of the array.  */
4252   len = GFC_TYPE_ARRAY_SIZE (type);
4253   if (!len || TREE_CODE (len) != INTEGER_CST)
4254     return NULL_TREE;
4255
4256   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4257   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4258                      fold_convert (gfc_array_index_type, tmp));
4259
4260   /* Convert arguments to the correct types.  */
4261   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4262     dest = gfc_build_addr_expr (pvoid_type_node, dest);
4263   else
4264     dest = fold_convert (pvoid_type_node, dest);
4265   len = fold_convert (size_type_node, len);
4266
4267   /* Construct call to __builtin_memset.  */
4268   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4269                          3, dest, integer_zero_node, len);
4270   return fold_convert (void_type_node, tmp);
4271 }
4272
4273
4274 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4275    that constructs the call to __builtin_memcpy.  */
4276
4277 static tree
4278 gfc_build_memcpy_call (tree dst, tree src, tree len)
4279 {
4280   tree tmp;
4281
4282   /* Convert arguments to the correct types.  */
4283   if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4284     dst = gfc_build_addr_expr (pvoid_type_node, dst);
4285   else
4286     dst = fold_convert (pvoid_type_node, dst);
4287
4288   if (!POINTER_TYPE_P (TREE_TYPE (src)))
4289     src = gfc_build_addr_expr (pvoid_type_node, src);
4290   else
4291     src = fold_convert (pvoid_type_node, src);
4292
4293   len = fold_convert (size_type_node, len);
4294
4295   /* Construct call to __builtin_memcpy.  */
4296   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4297   return fold_convert (void_type_node, tmp);
4298 }
4299
4300
4301 /* Try to efficiently translate dst(:) = src(:).  Return NULL if this
4302    can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
4303    source/rhs, both are gfc_full_array_ref_p which have been checked for
4304    dependencies.  */
4305
4306 static tree
4307 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4308 {
4309   tree dst, dlen, dtype;
4310   tree src, slen, stype;
4311   tree tmp;
4312
4313   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4314   src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4315
4316   dtype = TREE_TYPE (dst);
4317   if (POINTER_TYPE_P (dtype))
4318     dtype = TREE_TYPE (dtype);
4319   stype = TREE_TYPE (src);
4320   if (POINTER_TYPE_P (stype))
4321     stype = TREE_TYPE (stype);
4322
4323   if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4324     return NULL_TREE;
4325
4326   /* Determine the lengths of the arrays.  */
4327   dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4328   if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4329     return NULL_TREE;
4330   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4331   dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4332                       fold_convert (gfc_array_index_type, tmp));
4333
4334   slen = GFC_TYPE_ARRAY_SIZE (stype);
4335   if (!slen || TREE_CODE (slen) != INTEGER_CST)
4336     return NULL_TREE;
4337   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4338   slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4339                       fold_convert (gfc_array_index_type, tmp));
4340
4341   /* Sanity check that they are the same.  This should always be
4342      the case, as we should already have checked for conformance.  */
4343   if (!tree_int_cst_equal (slen, dlen))
4344     return NULL_TREE;
4345
4346   return gfc_build_memcpy_call (dst, src, dlen);
4347 }
4348
4349
4350 /* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
4351    this can't be done.  EXPR1 is the destination/lhs for which
4352    gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
4353
4354 static tree
4355 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4356 {
4357   unsigned HOST_WIDE_INT nelem;
4358   tree dst, dtype;
4359   tree src, stype;
4360   tree len;
4361   tree tmp;
4362
4363   nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4364   if (nelem == 0)
4365     return NULL_TREE;
4366
4367   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4368   dtype = TREE_TYPE (dst);
4369   if (POINTER_TYPE_P (dtype))
4370     dtype = TREE_TYPE (dtype);
4371   if (!GFC_ARRAY_TYPE_P (dtype))
4372     return NULL_TREE;
4373
4374   /* Determine the lengths of the array.  */
4375   len = GFC_TYPE_ARRAY_SIZE (dtype);
4376   if (!len || TREE_CODE (len) != INTEGER_CST)
4377     return NULL_TREE;
4378
4379   /* Confirm that the constructor is the same size.  */
4380   if (compare_tree_int (len, nelem) != 0)
4381     return NULL_TREE;
4382
4383   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4384   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4385                      fold_convert (gfc_array_index_type, tmp));
4386
4387   stype = gfc_typenode_for_spec (&expr2->ts);
4388   src = gfc_build_constant_array_constructor (expr2, stype);
4389
4390   stype = TREE_TYPE (src);
4391   if (POINTER_TYPE_P (stype))
4392     stype = TREE_TYPE (stype);
4393
4394   return gfc_build_memcpy_call (dst, src, len);
4395 }
4396
4397
4398 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4399    assignment.  EXPR1 is the destination/RHS and EXPR2 is the source/LHS.  */
4400
4401 static tree
4402 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4403 {
4404   gfc_se lse;
4405   gfc_se rse;
4406   gfc_ss *lss;
4407   gfc_ss *lss_section;
4408   gfc_ss *rss;
4409   gfc_loopinfo loop;
4410   tree tmp;
4411   stmtblock_t block;
4412   stmtblock_t body;
4413   bool l_is_temp;
4414
4415   /* Assignment of the form lhs = rhs.  */
4416   gfc_start_block (&block);
4417
4418   gfc_init_se (&lse, NULL);
4419   gfc_init_se (&rse, NULL);
4420
4421   /* Walk the lhs.  */
4422   lss = gfc_walk_expr (expr1);
4423   rss = NULL;
4424   if (lss != gfc_ss_terminator)
4425     {
4426       /* The assignment needs scalarization.  */
4427       lss_section = lss;
4428
4429       /* Find a non-scalar SS from the lhs.  */
4430       while (lss_section != gfc_ss_terminator
4431              && lss_section->type != GFC_SS_SECTION)
4432         lss_section = lss_section->next;
4433
4434       gcc_assert (lss_section != gfc_ss_terminator);
4435
4436       /* Initialize the scalarizer.  */
4437       gfc_init_loopinfo (&loop);
4438
4439       /* Walk the rhs.  */
4440       rss = gfc_walk_expr (expr2);
4441       if (rss == gfc_ss_terminator)
4442         {
4443           /* The rhs is scalar.  Add a ss for the expression.  */
4444           rss = gfc_get_ss ();
4445           rss->next = gfc_ss_terminator;
4446           rss->type = GFC_SS_SCALAR;
4447           rss->expr = expr2;
4448         }
4449       /* Associate the SS with the loop.  */
4450       gfc_add_ss_to_loop (&loop, lss);
4451       gfc_add_ss_to_loop (&loop, rss);
4452
4453       /* Calculate the bounds of the scalarization.  */
4454       gfc_conv_ss_startstride (&loop);
4455       /* Resolve any data dependencies in the statement.  */
4456       gfc_conv_resolve_dependencies (&loop, lss, rss);
4457       /* Setup the scalarizing loops.  */
4458       gfc_conv_loop_setup (&loop, &expr2->where);
4459
4460       /* Setup the gfc_se structures.  */
4461       gfc_copy_loopinfo_to_se (&lse, &loop);
4462       gfc_copy_loopinfo_to_se (&rse, &loop);
4463
4464       rse.ss = rss;
4465       gfc_mark_ss_chain_used (rss, 1);
4466       if (loop.temp_ss == NULL)
4467         {
4468           lse.ss = lss;
4469           gfc_mark_ss_chain_used (lss, 1);
4470         }
4471       else
4472         {
4473           lse.ss = loop.temp_ss;
4474           gfc_mark_ss_chain_used (lss, 3);
4475           gfc_mark_ss_chain_used (loop.temp_ss, 3);
4476         }
4477
4478       /* Start the scalarized loop body.  */
4479       gfc_start_scalarized_body (&loop, &body);
4480     }
4481   else
4482     gfc_init_block (&body);
4483
4484   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4485
4486   /* Translate the expression.  */
4487   gfc_conv_expr (&rse, expr2);
4488
4489   if (l_is_temp)
4490     {
4491       gfc_conv_tmp_array_ref (&lse);
4492       gfc_advance_se_ss_chain (&lse);
4493     }
4494   else
4495     gfc_conv_expr (&lse, expr1);
4496
4497   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4498                                  l_is_temp || init_flag,
4499                                  expr2->expr_type == EXPR_VARIABLE);
4500   gfc_add_expr_to_block (&body, tmp);
4501
4502   if (lss == gfc_ss_terminator)
4503     {
4504       /* Use the scalar assignment as is.  */
4505       gfc_add_block_to_block (&block, &body);
4506     }
4507   else
4508     {
4509       gcc_assert (lse.ss == gfc_ss_terminator
4510                   && rse.ss == gfc_ss_terminator);
4511
4512       if (l_is_temp)
4513         {
4514           gfc_trans_scalarized_loop_boundary (&loop, &body);
4515
4516           /* We need to copy the temporary to the actual lhs.  */
4517           gfc_init_se (&lse, NULL);
4518           gfc_init_se (&rse, NULL);
4519           gfc_copy_loopinfo_to_se (&lse, &loop);
4520           gfc_copy_loopinfo_to_se (&rse, &loop);
4521
4522           rse.ss = loop.temp_ss;
4523           lse.ss = lss;
4524
4525           gfc_conv_tmp_array_ref (&rse);
4526           gfc_advance_se_ss_chain (&rse);
4527           gfc_conv_expr (&lse, expr1);
4528
4529           gcc_assert (lse.ss == gfc_ss_terminator
4530                       && rse.ss == gfc_ss_terminator);
4531
4532           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4533                                          false, false);
4534           gfc_add_expr_to_block (&body, tmp);
4535         }
4536
4537       /* Generate the copying loops.  */
4538       gfc_trans_scalarizing_loops (&loop, &body);
4539
4540       /* Wrap the whole thing up.  */
4541       gfc_add_block_to_block (&block, &loop.pre);
4542       gfc_add_block_to_block (&block, &loop.post);
4543
4544       gfc_cleanup_loop (&loop);
4545     }
4546
4547   return gfc_finish_block (&block);
4548 }
4549
4550
4551 /* Check whether EXPR is a copyable array.  */
4552
4553 static bool
4554 copyable_array_p (gfc_expr * expr)
4555 {
4556   if (expr->expr_type != EXPR_VARIABLE)
4557     return false;
4558
4559   /* First check it's an array.  */
4560   if (expr->rank < 1 || !expr->ref || expr->ref->next)
4561     return false;
4562
4563   if (!gfc_full_array_ref_p (expr->ref))
4564     return false;
4565
4566   /* Next check that it's of a simple enough type.  */
4567   switch (expr->ts.type)
4568     {
4569     case BT_INTEGER:
4570     case BT_REAL:
4571     case BT_COMPLEX:
4572     case BT_LOGICAL:
4573       return true;
4574
4575     case BT_CHARACTER:
4576       return false;
4577
4578     case BT_DERIVED:
4579       return !expr->ts.derived->attr.alloc_comp;
4580
4581     default:
4582       break;
4583     }
4584
4585   return false;
4586 }
4587
4588 /* Translate an assignment.  */
4589
4590 tree
4591 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4592 {
4593   tree tmp;
4594
4595   /* Special case a single function returning an array.  */
4596   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4597     {
4598       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4599       if (tmp)
4600         return tmp;
4601     }
4602
4603   /* Special case assigning an array to zero.  */
4604   if (copyable_array_p (expr1)
4605       && is_zero_initializer_p (expr2))
4606     {
4607       tmp = gfc_trans_zero_assign (expr1);
4608       if (tmp)
4609         return tmp;
4610     }
4611
4612   /* Special case copying one array to another.  */
4613   if (copyable_array_p (expr1)
4614       && copyable_array_p (expr2)
4615       && gfc_compare_types (&expr1->ts, &expr2->ts)
4616       && !gfc_check_dependency (expr1, expr2, 0))
4617     {
4618       tmp = gfc_trans_array_copy (expr1, expr2);
4619       if (tmp)
4620         return tmp;
4621     }
4622
4623   /* Special case initializing an array from a constant array constructor.  */
4624   if (copyable_array_p (expr1)
4625       && expr2->expr_type == EXPR_ARRAY
4626       && gfc_compare_types (&expr1->ts, &expr2->ts))
4627     {
4628       tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4629       if (tmp)
4630         return tmp;
4631     }
4632
4633   /* Fallback to the scalarizer to generate explicit loops.  */
4634   return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4635 }
4636
4637 tree
4638 gfc_trans_init_assign (gfc_code * code)
4639 {
4640   return gfc_trans_assignment (code->expr, code->expr2, true);
4641 }
4642
4643 tree
4644 gfc_trans_assign (gfc_code * code)
4645 {
4646   return gfc_trans_assignment (code->expr, code->expr2, false);
4647 }