gcc/fortran/trans-expr.c

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