gcc/fortran/trans-expr.c

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