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