gcc/fortran/trans-expr.c

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