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