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