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     }
2114
2115   if (se->ss != NULL)
2116     {
2117       if (!sym->attr.elemental)
2118         {
2119           gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2120           if (se->ss->useflags)
2121             {
2122               gcc_assert (gfc_return_by_reference (sym)
2123                       && sym->result->attr.dimension);
2124               gcc_assert (se->loop != NULL);
2125
2126               /* Access the previously obtained result.  */
2127               gfc_conv_tmp_array_ref (se);
2128               gfc_advance_se_ss_chain (se);
2129               return 0;
2130             }
2131         }
2132       info = &se->ss->data.info;
2133     }
2134   else
2135     info = NULL;
2136
2137   gfc_init_block (&post);
2138   gfc_init_interface_mapping (&mapping);
2139   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2140                                   && sym->ts.cl->length
2141                                   && sym->ts.cl->length->expr_type
2142                                                 != EXPR_CONSTANT)
2143                               || sym->attr.dimension);
2144   formal = sym->formal;
2145   /* Evaluate the arguments.  */
2146   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2147     {
2148       e = arg->expr;
2149       fsym = formal ? formal->sym : NULL;
2150       parm_kind = MISSING;
2151       if (e == NULL)
2152         {
2153
2154           if (se->ignore_optional)
2155             {
2156               /* Some intrinsics have already been resolved to the correct
2157                  parameters.  */
2158               continue;
2159             }
2160           else if (arg->label)
2161             {
2162               has_alternate_specifier = 1;
2163               continue;
2164             }
2165           else
2166             {
2167               /* Pass a NULL pointer for an absent arg.  */
2168               gfc_init_se (&parmse, NULL);
2169               parmse.expr = null_pointer_node;
2170               if (arg->missing_arg_type == BT_CHARACTER)
2171                 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2172             }
2173         }
2174       else if (se->ss && se->ss->useflags)
2175         {
2176           /* An elemental function inside a scalarized loop.  */
2177           gfc_init_se (&parmse, se);
2178           gfc_conv_expr_reference (&parmse, e);
2179           parm_kind = ELEMENTAL;
2180         }
2181       else
2182         {
2183           /* A scalar or transformational function.  */
2184           gfc_init_se (&parmse, NULL);
2185           argss = gfc_walk_expr (e);
2186
2187           if (argss == gfc_ss_terminator)
2188             {
2189               if (fsym && fsym->attr.value)
2190                 {
2191                   if (fsym->ts.type == BT_CHARACTER
2192                       && fsym->ts.is_c_interop
2193                       && fsym->ns->proc_name != NULL
2194                       && fsym->ns->proc_name->attr.is_bind_c)
2195                     {
2196                       parmse.expr = NULL;
2197                       gfc_conv_scalar_char_value (fsym, &parmse, &e);
2198                       if (parmse.expr == NULL)
2199                         gfc_conv_expr (&parmse, e);
2200                     }
2201                   else
2202                     gfc_conv_expr (&parmse, e);
2203                 }
2204               else if (arg->name && arg->name[0] == '%')
2205                 /* Argument list functions %VAL, %LOC and %REF are signalled
2206                    through arg->name.  */
2207                 conv_arglist_function (&parmse, arg->expr, arg->name);
2208               else if ((e->expr_type == EXPR_FUNCTION)
2209                           && e->symtree->n.sym->attr.pointer
2210                           && fsym && fsym->attr.target)
2211                 {
2212                   gfc_conv_expr (&parmse, e);
2213                   parmse.expr = build_fold_addr_expr (parmse.expr);
2214                 }
2215               else
2216                 {
2217                   gfc_conv_expr_reference (&parmse, e);
2218                   if (fsym && fsym->attr.pointer
2219                       && fsym->attr.flavor != FL_PROCEDURE
2220                       && e->expr_type != EXPR_NULL)
2221                     {
2222                       /* Scalar pointer dummy args require an extra level of
2223                          indirection. The null pointer already contains
2224                          this level of indirection.  */
2225                       parm_kind = SCALAR_POINTER;
2226                       parmse.expr = build_fold_addr_expr (parmse.expr);
2227                     }
2228                 }
2229             }
2230           else
2231             {
2232               /* If the procedure requires an explicit interface, the actual
2233                  argument is passed according to the corresponding formal
2234                  argument.  If the corresponding formal argument is a POINTER,
2235                  ALLOCATABLE or assumed shape, we do not use g77's calling
2236                  convention, and pass the address of the array descriptor
2237                  instead. Otherwise we use g77's calling convention.  */
2238               int f;
2239               f = (fsym != NULL)
2240                   && !(fsym->attr.pointer || fsym->attr.allocatable)
2241                   && fsym->as->type != AS_ASSUMED_SHAPE;
2242               f = f || !sym->attr.always_explicit;
2243
2244               if (e->expr_type == EXPR_VARIABLE
2245                     && is_subref_array (e))
2246                 /* The actual argument is a component reference to an
2247                    array of derived types.  In this case, the argument
2248                    is converted to a temporary, which is passed and then
2249                    written back after the procedure call.  */
2250                 gfc_conv_subref_array_arg (&parmse, e, f,
2251                         fsym ? fsym->attr.intent : INTENT_INOUT);
2252               else
2253                 gfc_conv_array_parameter (&parmse, e, argss, f);
2254
2255               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2256                  allocated on entry, it must be deallocated.  */
2257               if (fsym && fsym->attr.allocatable
2258                   && fsym->attr.intent == INTENT_OUT)
2259                 {
2260                   tmp = build_fold_indirect_ref (parmse.expr);
2261                   tmp = gfc_trans_dealloc_allocated (tmp);
2262                   gfc_add_expr_to_block (&se->pre, tmp);
2263                 }
2264
2265             }
2266         }
2267
2268       /* The case with fsym->attr.optional is that of a user subroutine
2269          with an interface indicating an optional argument.  When we call
2270          an intrinsic subroutine, however, fsym is NULL, but we might still
2271          have an optional argument, so we proceed to the substitution
2272          just in case.  */
2273       if (e && (fsym == NULL || fsym->attr.optional))
2274         {
2275           /* If an optional argument is itself an optional dummy argument,
2276              check its presence and substitute a null if absent.  */
2277           if (e->expr_type == EXPR_VARIABLE
2278               && e->symtree->n.sym->attr.optional)
2279             gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts);
2280         }
2281
2282       if (fsym && e)
2283         {
2284           /* Obtain the character length of an assumed character length
2285              length procedure from the typespec.  */
2286           if (fsym->ts.type == BT_CHARACTER
2287               && parmse.string_length == NULL_TREE
2288               && e->ts.type == BT_PROCEDURE
2289               && e->symtree->n.sym->ts.type == BT_CHARACTER
2290               && e->symtree->n.sym->ts.cl->length != NULL)
2291             {
2292               gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2293               parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2294             }
2295         }
2296
2297       if (fsym && need_interface_mapping)
2298         gfc_add_interface_mapping (&mapping, fsym, &parmse);
2299
2300       gfc_add_block_to_block (&se->pre, &parmse.pre);
2301       gfc_add_block_to_block (&post, &parmse.post);
2302
2303       /* Allocated allocatable components of derived types must be
2304          deallocated for INTENT(OUT) dummy arguments and non-variable
2305          scalars.  Non-variable arrays are dealt with in trans-array.c
2306          (gfc_conv_array_parameter).  */
2307       if (e && e->ts.type == BT_DERIVED
2308             && e->ts.derived->attr.alloc_comp
2309             && ((formal && formal->sym->attr.intent == INTENT_OUT)
2310                    ||
2311                 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2312         {
2313           int parm_rank;
2314           tmp = build_fold_indirect_ref (parmse.expr);
2315           parm_rank = e->rank;
2316           switch (parm_kind)
2317             {
2318             case (ELEMENTAL):
2319             case (SCALAR):
2320               parm_rank = 0;
2321               break;
2322
2323             case (SCALAR_POINTER):
2324               tmp = build_fold_indirect_ref (tmp);
2325               break;
2326             case (ARRAY):
2327               tmp = parmse.expr;
2328               break;
2329             }
2330
2331           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2332           if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2333             tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2334                             tmp, build_empty_stmt ());
2335
2336           if (e->expr_type != EXPR_VARIABLE)
2337             /* Don't deallocate non-variables until they have been used.  */
2338             gfc_add_expr_to_block (&se->post, tmp);
2339           else
2340             {
2341               gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2342               gfc_add_expr_to_block (&se->pre, tmp);
2343             }
2344         }
2345
2346       /* Character strings are passed as two parameters, a length and a
2347          pointer.  */
2348       if (parmse.string_length != NULL_TREE)
2349         stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2350
2351       arglist = gfc_chainon_list (arglist, parmse.expr);
2352     }
2353   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2354
2355   ts = sym->ts;
2356   if (ts.type == BT_CHARACTER)
2357     {
2358       if (sym->ts.cl->length == NULL)
2359         {
2360           /* Assumed character length results are not allowed by 5.1.1.5 of the
2361              standard and are trapped in resolve.c; except in the case of SPREAD
2362              (and other intrinsics?) and dummy functions.  In the case of SPREAD,
2363              we take the character length of the first argument for the result.
2364              For dummies, we have to look through the formal argument list for
2365              this function and use the character length found there.*/
2366           if (!sym->attr.dummy)
2367             cl.backend_decl = TREE_VALUE (stringargs);
2368           else
2369             {
2370               formal = sym->ns->proc_name->formal;
2371               for (; formal; formal = formal->next)
2372                 if (strcmp (formal->sym->name, sym->name) == 0)
2373                   cl.backend_decl = formal->sym->ts.cl->backend_decl;
2374             }
2375         }
2376         else
2377         {
2378           tree tmp;
2379
2380           /* Calculate the length of the returned string.  */
2381           gfc_init_se (&parmse, NULL);
2382           if (need_interface_mapping)
2383             gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2384           else
2385             gfc_conv_expr (&parmse, sym->ts.cl->length);
2386           gfc_add_block_to_block (&se->pre, &parmse.pre);
2387           gfc_add_block_to_block (&se->post, &parmse.post);
2388
2389           tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2390           tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2391                              build_int_cst (gfc_charlen_type_node, 0));
2392           cl.backend_decl = tmp;
2393         }
2394
2395       /* Set up a charlen structure for it.  */
2396       cl.next = NULL;
2397       cl.length = NULL;
2398       ts.cl = &cl;
2399
2400       len = cl.backend_decl;
2401     }
2402
2403   byref = gfc_return_by_reference (sym);
2404   if (byref)
2405     {
2406       if (se->direct_byref)
2407         {
2408           /* Sometimes, too much indirection can be applied; eg. for
2409              function_result = array_valued_recursive_function.  */
2410           if (TREE_TYPE (TREE_TYPE (se->expr))
2411                 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2412                 && GFC_DESCRIPTOR_TYPE_P
2413                         (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2414             se->expr = build_fold_indirect_ref (se->expr);
2415
2416           retargs = gfc_chainon_list (retargs, se->expr);
2417         }
2418       else if (sym->result->attr.dimension)
2419         {
2420           gcc_assert (se->loop && info);
2421
2422           /* Set the type of the array.  */
2423           tmp = gfc_typenode_for_spec (&ts);
2424           info->dimen = se->loop->dimen;
2425
2426           /* Evaluate the bounds of the result, if known.  */
2427           gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2428
2429           /* Create a temporary to store the result.  In case the function
2430              returns a pointer, the temporary will be a shallow copy and
2431              mustn't be deallocated.  */
2432           callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2433           gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2434                                        false, !sym->attr.pointer, callee_alloc);
2435
2436           /* Pass the temporary as the first argument.  */
2437           tmp = info->descriptor;
2438           tmp = build_fold_addr_expr (tmp);
2439           retargs = gfc_chainon_list (retargs, tmp);
2440         }
2441       else if (ts.type == BT_CHARACTER)
2442         {
2443           /* Pass the string length.  */
2444           type = gfc_get_character_type (ts.kind, ts.cl);
2445           type = build_pointer_type (type);
2446
2447           /* Return an address to a char[0:len-1]* temporary for
2448              character pointers.  */
2449           if (sym->attr.pointer || sym->attr.allocatable)
2450             {
2451               /* Build char[0:len-1] * pstr.  */
2452               tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2453                                  build_int_cst (gfc_charlen_type_node, 1));
2454               tmp = build_range_type (gfc_array_index_type,
2455                                       gfc_index_zero_node, tmp);
2456               tmp = build_array_type (gfc_character1_type_node, tmp);
2457               var = gfc_create_var (build_pointer_type (tmp), "pstr");
2458
2459               /* Provide an address expression for the function arguments.  */
2460               var = build_fold_addr_expr (var);
2461             }
2462           else
2463             var = gfc_conv_string_tmp (se, type, len);
2464
2465           retargs = gfc_chainon_list (retargs, var);
2466         }
2467       else
2468         {
2469           gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2470
2471           type = gfc_get_complex_type (ts.kind);
2472           var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2473           retargs = gfc_chainon_list (retargs, var);
2474         }
2475
2476       /* Add the string length to the argument list.  */
2477       if (ts.type == BT_CHARACTER)
2478         retargs = gfc_chainon_list (retargs, len);
2479     }
2480   gfc_free_interface_mapping (&mapping);
2481
2482   /* Add the return arguments.  */
2483   arglist = chainon (retargs, arglist);
2484
2485   /* Add the hidden string length parameters to the arguments.  */
2486   arglist = chainon (arglist, stringargs);
2487
2488   /* We may want to append extra arguments here.  This is used e.g. for
2489      calls to libgfortran_matmul_??, which need extra information.  */
2490   if (append_args != NULL_TREE)
2491     arglist = chainon (arglist, append_args);
2492
2493   /* Generate the actual call.  */
2494   gfc_conv_function_val (se, sym);
2495
2496   /* If there are alternate return labels, function type should be
2497      integer.  Can't modify the type in place though, since it can be shared
2498      with other functions.  For dummy arguments, the typing is done to
2499      to this result, even if it has to be repeated for each call.  */
2500   if (has_alternate_specifier
2501       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2502     {
2503       if (!sym->attr.dummy)
2504         {
2505           TREE_TYPE (sym->backend_decl)
2506                 = build_function_type (integer_type_node,
2507                       TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2508           se->expr = build_fold_addr_expr (sym->backend_decl);
2509         }
2510       else
2511         TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2512     }
2513
2514   fntype = TREE_TYPE (TREE_TYPE (se->expr));
2515   se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2516
2517   /* If we have a pointer function, but we don't want a pointer, e.g.
2518      something like
2519         x = f()
2520      where f is pointer valued, we have to dereference the result.  */
2521   if (!se->want_pointer && !byref && sym->attr.pointer)
2522     se->expr = build_fold_indirect_ref (se->expr);
2523
2524   /* f2c calling conventions require a scalar default real function to
2525      return a double precision result.  Convert this back to default
2526      real.  We only care about the cases that can happen in Fortran 77.
2527   */
2528   if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2529       && sym->ts.kind == gfc_default_real_kind
2530       && !sym->attr.always_explicit)
2531     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2532
2533   /* A pure function may still have side-effects - it may modify its
2534      parameters.  */
2535   TREE_SIDE_EFFECTS (se->expr) = 1;
2536 #if 0
2537   if (!sym->attr.pure)
2538     TREE_SIDE_EFFECTS (se->expr) = 1;
2539 #endif
2540
2541   if (byref)
2542     {
2543       /* Add the function call to the pre chain.  There is no expression.  */
2544       gfc_add_expr_to_block (&se->pre, se->expr);
2545       se->expr = NULL_TREE;
2546
2547       if (!se->direct_byref)
2548         {
2549           if (sym->attr.dimension)
2550             {
2551               if (flag_bounds_check)
2552                 {
2553                   /* Check the data pointer hasn't been modified.  This would
2554                      happen in a function returning a pointer.  */
2555                   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2556                   tmp = fold_build2 (NE_EXPR, boolean_type_node,
2557                                      tmp, info->data);
2558                   gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
2559                 }
2560               se->expr = info->descriptor;
2561               /* Bundle in the string length.  */
2562               se->string_length = len;
2563             }
2564           else if (sym->ts.type == BT_CHARACTER)
2565             {
2566               /* Dereference for character pointer results.  */
2567               if (sym->attr.pointer || sym->attr.allocatable)
2568                 se->expr = build_fold_indirect_ref (var);
2569               else
2570                 se->expr = var;
2571
2572               se->string_length = len;
2573             }
2574           else
2575             {
2576               gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2577               se->expr = build_fold_indirect_ref (var);
2578             }
2579         }
2580     }
2581
2582   /* Follow the function call with the argument post block.  */
2583   if (byref)
2584     gfc_add_block_to_block (&se->pre, &post);
2585   else
2586     gfc_add_block_to_block (&se->post, &post);
2587
2588   return has_alternate_specifier;
2589 }
2590
2591
2592 /* Generate code to copy a string.  */
2593
2594 static void
2595 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2596                        tree slength, tree src)
2597 {
2598   tree tmp, dlen, slen;
2599   tree dsc;
2600   tree ssc;
2601   tree cond;
2602   tree cond2;
2603   tree tmp2;
2604   tree tmp3;
2605   tree tmp4;
2606   stmtblock_t tempblock;
2607
2608   dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2609   slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2610
2611   /* Deal with single character specially.  */
2612   dsc = gfc_to_single_character (dlen, dest);
2613   ssc = gfc_to_single_character (slen, src);
2614   if (dsc != NULL_TREE && ssc != NULL_TREE)
2615     {
2616       gfc_add_modify_expr (block, dsc, ssc);
2617       return;
2618     }
2619
2620   /* Do nothing if the destination length is zero.  */
2621   cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2622                       build_int_cst (size_type_node, 0));
2623
2624   /* The following code was previously in _gfortran_copy_string:
2625
2626        // The two strings may overlap so we use memmove.
2627        void
2628        copy_string (GFC_INTEGER_4 destlen, char * dest,
2629                     GFC_INTEGER_4 srclen, const char * src)
2630        {
2631          if (srclen >= destlen)
2632            {
2633              // This will truncate if too long.
2634              memmove (dest, src, destlen);
2635            }
2636          else
2637            {
2638              memmove (dest, src, srclen);
2639              // Pad with spaces.
2640              memset (&dest[srclen], ' ', destlen - srclen);
2641            }
2642        }
2643
2644      We're now doing it here for better optimization, but the logic
2645      is the same.  */
2646
2647   /* Truncate string if source is too long.  */
2648   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2649   tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2650                           3, dest, src, dlen);
2651
2652   /* Else copy and pad with spaces.  */
2653   tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2654                           3, dest, src, slen);
2655
2656   tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
2657                       fold_convert (sizetype, slen));
2658   tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2659                           tmp4,
2660                           build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2661                                          lang_hooks.to_target_charset (' ')),
2662                           fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2663                                        dlen, slen));
2664
2665   gfc_init_block (&tempblock);
2666   gfc_add_expr_to_block (&tempblock, tmp3);
2667   gfc_add_expr_to_block (&tempblock, tmp4);
2668   tmp3 = gfc_finish_block (&tempblock);
2669
2670   /* The whole copy_string function is there.  */
2671   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2672   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2673   gfc_add_expr_to_block (block, tmp);
2674 }
2675
2676
2677 /* Translate a statement function.
2678    The value of a statement function reference is obtained by evaluating the
2679    expression using the values of the actual arguments for the values of the
2680    corresponding dummy arguments.  */
2681
2682 static void
2683 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2684 {
2685   gfc_symbol *sym;
2686   gfc_symbol *fsym;
2687   gfc_formal_arglist *fargs;
2688   gfc_actual_arglist *args;
2689   gfc_se lse;
2690   gfc_se rse;
2691   gfc_saved_var *saved_vars;
2692   tree *temp_vars;
2693   tree type;
2694   tree tmp;
2695   int n;
2696
2697   sym = expr->symtree->n.sym;
2698   args = expr->value.function.actual;
2699   gfc_init_se (&lse, NULL);
2700   gfc_init_se (&rse, NULL);
2701
2702   n = 0;
2703   for (fargs = sym->formal; fargs; fargs = fargs->next)
2704     n++;
2705   saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2706   temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2707
2708   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2709     {
2710       /* Each dummy shall be specified, explicitly or implicitly, to be
2711          scalar.  */
2712       gcc_assert (fargs->sym->attr.dimension == 0);
2713       fsym = fargs->sym;
2714
2715       /* Create a temporary to hold the value.  */
2716       type = gfc_typenode_for_spec (&fsym->ts);
2717       temp_vars[n] = gfc_create_var (type, fsym->name);
2718
2719       if (fsym->ts.type == BT_CHARACTER)
2720         {
2721           /* Copy string arguments.  */
2722           tree arglen;
2723
2724           gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2725                   && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2726
2727           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2728           tmp = gfc_build_addr_expr (build_pointer_type (type),
2729                                      temp_vars[n]);
2730
2731           gfc_conv_expr (&rse, args->expr);
2732           gfc_conv_string_parameter (&rse);
2733           gfc_add_block_to_block (&se->pre, &lse.pre);
2734           gfc_add_block_to_block (&se->pre, &rse.pre);
2735
2736           gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2737                                  rse.expr);
2738           gfc_add_block_to_block (&se->pre, &lse.post);
2739           gfc_add_block_to_block (&se->pre, &rse.post);
2740         }
2741       else
2742         {
2743           /* For everything else, just evaluate the expression.  */
2744           gfc_conv_expr (&lse, args->expr);
2745
2746           gfc_add_block_to_block (&se->pre, &lse.pre);
2747           gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2748           gfc_add_block_to_block (&se->pre, &lse.post);
2749         }
2750
2751       args = args->next;
2752     }
2753
2754   /* Use the temporary variables in place of the real ones.  */
2755   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2756     gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2757
2758   gfc_conv_expr (se, sym->value);
2759
2760   if (sym->ts.type == BT_CHARACTER)
2761     {
2762       gfc_conv_const_charlen (sym->ts.cl);
2763
2764       /* Force the expression to the correct length.  */
2765       if (!INTEGER_CST_P (se->string_length)
2766           || tree_int_cst_lt (se->string_length,
2767                               sym->ts.cl->backend_decl))
2768         {
2769           type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2770           tmp = gfc_create_var (type, sym->name);
2771           tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2772           gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2773                                  se->string_length, se->expr);
2774           se->expr = tmp;
2775         }
2776       se->string_length = sym->ts.cl->backend_decl;
2777     }
2778
2779   /* Restore the original variables.  */
2780   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2781     gfc_restore_sym (fargs->sym, &saved_vars[n]);
2782   gfc_free (saved_vars);
2783 }
2784
2785
2786 /* Translate a function expression.  */
2787
2788 static void
2789 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2790 {
2791   gfc_symbol *sym;
2792
2793   if (expr->value.function.isym)
2794     {
2795       gfc_conv_intrinsic_function (se, expr);
2796       return;
2797     }
2798
2799   /* We distinguish statement functions from general functions to improve
2800      runtime performance.  */
2801   if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2802     {
2803       gfc_conv_statement_function (se, expr);
2804       return;
2805     }
2806
2807   /* expr.value.function.esym is the resolved (specific) function symbol for
2808      most functions.  However this isn't set for dummy procedures.  */
2809   sym = expr->value.function.esym;
2810   if (!sym)
2811     sym = expr->symtree->n.sym;
2812   gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2813 }
2814
2815
2816 static void
2817 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2818 {
2819   gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2820   gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2821
2822   gfc_conv_tmp_array_ref (se);
2823   gfc_advance_se_ss_chain (se);
2824 }
2825
2826
2827 /* Build a static initializer.  EXPR is the expression for the initial value.
2828    The other parameters describe the variable of the component being
2829    initialized. EXPR may be null.  */
2830
2831 tree
2832 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2833                       bool array, bool pointer)
2834 {
2835   gfc_se se;
2836
2837   if (!(expr || pointer))
2838     return NULL_TREE;
2839
2840   /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
2841      (these are the only two iso_c_binding derived types that can be
2842      used as initialization expressions).  If so, we need to modify
2843      the 'expr' to be that for a (void *).  */
2844   if (expr != NULL && expr->ts.type == BT_DERIVED
2845       && expr->ts.is_iso_c && expr->ts.derived)
2846     {
2847       gfc_symbol *derived = expr->ts.derived;
2848
2849       expr = gfc_int_expr (0);
2850
2851       /* The derived symbol has already been converted to a (void *).  Use
2852          its kind.  */
2853       expr->ts.f90_type = derived->ts.f90_type;
2854       expr->ts.kind = derived->ts.kind;
2855     }
2856
2857   if (array)
2858     {
2859       /* Arrays need special handling.  */
2860       if (pointer)
2861         return gfc_build_null_descriptor (type);
2862       else
2863         return gfc_conv_array_initializer (type, expr);
2864     }
2865   else if (pointer)
2866     return fold_convert (type, null_pointer_node);
2867   else
2868     {
2869       switch (ts->type)
2870         {
2871         case BT_DERIVED:
2872           gfc_init_se (&se, NULL);
2873           gfc_conv_structure (&se, expr, 1);
2874           return se.expr;
2875
2876         case BT_CHARACTER:
2877           return gfc_conv_string_init (ts->cl->backend_decl,expr);
2878
2879         default:
2880           gfc_init_se (&se, NULL);
2881           gfc_conv_constant (&se, expr);
2882           return se.expr;
2883         }
2884     }
2885 }
2886
2887 static tree
2888 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2889 {
2890   gfc_se rse;
2891   gfc_se lse;
2892   gfc_ss *rss;
2893   gfc_ss *lss;
2894   stmtblock_t body;
2895   stmtblock_t block;
2896   gfc_loopinfo loop;
2897   int n;
2898   tree tmp;
2899
2900   gfc_start_block (&block);
2901
2902   /* Initialize the scalarizer.  */
2903   gfc_init_loopinfo (&loop);
2904
2905   gfc_init_se (&lse, NULL);
2906   gfc_init_se (&rse, NULL);
2907
2908   /* Walk the rhs.  */
2909   rss = gfc_walk_expr (expr);
2910   if (rss == gfc_ss_terminator)
2911     {
2912       /* The rhs is scalar.  Add a ss for the expression.  */
2913       rss = gfc_get_ss ();
2914       rss->next = gfc_ss_terminator;
2915       rss->type = GFC_SS_SCALAR;
2916       rss->expr = expr;
2917     }
2918
2919   /* Create a SS for the destination.  */
2920   lss = gfc_get_ss ();
2921   lss->type = GFC_SS_COMPONENT;
2922   lss->expr = NULL;
2923   lss->shape = gfc_get_shape (cm->as->rank);
2924   lss->next = gfc_ss_terminator;
2925   lss->data.info.dimen = cm->as->rank;
2926   lss->data.info.descriptor = dest;
2927   lss->data.info.data = gfc_conv_array_data (dest);
2928   lss->data.info.offset = gfc_conv_array_offset (dest);
2929   for (n = 0; n < cm->as->rank; n++)
2930     {
2931       lss->data.info.dim[n] = n;
2932       lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2933       lss->data.info.stride[n] = gfc_index_one_node;
2934
2935       mpz_init (lss->shape[n]);
2936       mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2937                cm->as->lower[n]->value.integer);
2938       mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2939     }
2940
2941   /* Associate the SS with the loop.  */
2942   gfc_add_ss_to_loop (&loop, lss);
2943   gfc_add_ss_to_loop (&loop, rss);
2944
2945   /* Calculate the bounds of the scalarization.  */
2946   gfc_conv_ss_startstride (&loop);
2947
2948   /* Setup the scalarizing loops.  */
2949   gfc_conv_loop_setup (&loop);
2950
2951   /* Setup the gfc_se structures.  */
2952   gfc_copy_loopinfo_to_se (&lse, &loop);
2953   gfc_copy_loopinfo_to_se (&rse, &loop);
2954
2955   rse.ss = rss;
2956   gfc_mark_ss_chain_used (rss, 1);
2957   lse.ss = lss;
2958   gfc_mark_ss_chain_used (lss, 1);
2959
2960   /* Start the scalarized loop body.  */
2961   gfc_start_scalarized_body (&loop, &body);
2962
2963   gfc_conv_tmp_array_ref (&lse);
2964   if (cm->ts.type == BT_CHARACTER)
2965     lse.string_length = cm->ts.cl->backend_decl;
2966
2967   gfc_conv_expr (&rse, expr);
2968
2969   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2970   gfc_add_expr_to_block (&body, tmp);
2971
2972   gcc_assert (rse.ss == gfc_ss_terminator);
2973
2974   /* Generate the copying loops.  */
2975   gfc_trans_scalarizing_loops (&loop, &body);
2976
2977   /* Wrap the whole thing up.  */
2978   gfc_add_block_to_block (&block, &loop.pre);
2979   gfc_add_block_to_block (&block, &loop.post);
2980
2981   for (n = 0; n < cm->as->rank; n++)
2982     mpz_clear (lss->shape[n]);
2983   gfc_free (lss->shape);
2984
2985   gfc_cleanup_loop (&loop);
2986
2987   return gfc_finish_block (&block);
2988 }
2989
2990
2991 /* Assign a single component of a derived type constructor.  */
2992
2993 static tree
2994 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2995 {
2996   gfc_se se;
2997   gfc_se lse;
2998   gfc_ss *rss;
2999   stmtblock_t block;
3000   tree tmp;
3001   tree offset;
3002   int n;
3003
3004   gfc_start_block (&block);
3005
3006   if (cm->pointer)
3007     {
3008       gfc_init_se (&se, NULL);
3009       /* Pointer component.  */
3010       if (cm->dimension)
3011         {
3012           /* Array pointer.  */
3013           if (expr->expr_type == EXPR_NULL)
3014             gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3015           else
3016             {
3017               rss = gfc_walk_expr (expr);
3018               se.direct_byref = 1;
3019               se.expr = dest;
3020               gfc_conv_expr_descriptor (&se, expr, rss);
3021               gfc_add_block_to_block (&block, &se.pre);
3022               gfc_add_block_to_block (&block, &se.post);
3023             }
3024         }
3025       else
3026         {
3027           /* Scalar pointers.  */
3028           se.want_pointer = 1;
3029           gfc_conv_expr (&se, expr);
3030           gfc_add_block_to_block (&block, &se.pre);
3031           gfc_add_modify_expr (&block, dest,
3032                                fold_convert (TREE_TYPE (dest), se.expr));
3033           gfc_add_block_to_block (&block, &se.post);
3034         }
3035     }
3036   else if (cm->dimension)
3037     {
3038       if (cm->allocatable && expr->expr_type == EXPR_NULL)
3039         gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3040       else if (cm->allocatable)
3041         {
3042           tree tmp2;
3043
3044           gfc_init_se (&se, NULL);
3045
3046           rss = gfc_walk_expr (expr);
3047           se.want_pointer = 0;
3048           gfc_conv_expr_descriptor (&se, expr, rss);
3049           gfc_add_block_to_block (&block, &se.pre);
3050
3051           tmp = fold_convert (TREE_TYPE (dest), se.expr);
3052           gfc_add_modify_expr (&block, dest, tmp);
3053
3054           if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3055             tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3056                                        cm->as->rank);
3057           else
3058             tmp = gfc_duplicate_allocatable (dest, se.expr,
3059                                              TREE_TYPE(cm->backend_decl),
3060                                              cm->as->rank);
3061
3062           gfc_add_expr_to_block (&block, tmp);
3063
3064           gfc_add_block_to_block (&block, &se.post);
3065           gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3066
3067           /* Shift the lbound and ubound of temporaries to being unity, rather
3068              than zero, based.  Calculate the offset for all cases.  */
3069           offset = gfc_conv_descriptor_offset (dest);
3070           gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3071           tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3072           for (n = 0; n < expr->rank; n++)
3073             {
3074               if (expr->expr_type != EXPR_VARIABLE
3075                     && expr->expr_type != EXPR_CONSTANT)
3076                 {
3077                   tree span;
3078                   tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3079                   span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3080                             gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3081                   gfc_add_modify_expr (&block, tmp,
3082                                        fold_build2 (PLUS_EXPR,
3083                                                     gfc_array_index_type,
3084                                                     span, gfc_index_one_node));
3085                   tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3086                   gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3087                 }
3088               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3089                                  gfc_conv_descriptor_lbound (dest,
3090                                                              gfc_rank_cst[n]),
3091                                  gfc_conv_descriptor_stride (dest,
3092                                                              gfc_rank_cst[n]));
3093               gfc_add_modify_expr (&block, tmp2, tmp);
3094               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3095               gfc_add_modify_expr (&block, offset, tmp);
3096             }
3097         }
3098       else
3099         {
3100           tmp = gfc_trans_subarray_assign (dest, cm, expr);
3101           gfc_add_expr_to_block (&block, tmp);
3102         }
3103     }
3104   else if (expr->ts.type == BT_DERIVED)
3105     {
3106       if (expr->expr_type != EXPR_STRUCTURE)
3107         {
3108           gfc_init_se (&se, NULL);
3109           gfc_conv_expr (&se, expr);
3110           gfc_add_modify_expr (&block, dest,
3111                                fold_convert (TREE_TYPE (dest), se.expr));
3112         }
3113       else
3114         {
3115           /* Nested constructors.  */
3116           tmp = gfc_trans_structure_assign (dest, expr);
3117           gfc_add_expr_to_block (&block, tmp);
3118         }
3119     }
3120   else
3121     {
3122       /* Scalar component.  */
3123       gfc_init_se (&se, NULL);
3124       gfc_init_se (&lse, NULL);
3125
3126       gfc_conv_expr (&se, expr);
3127       if (cm->ts.type == BT_CHARACTER)
3128         lse.string_length = cm->ts.cl->backend_decl;
3129       lse.expr = dest;
3130       tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3131       gfc_add_expr_to_block (&block, tmp);
3132     }
3133   return gfc_finish_block (&block);
3134 }
3135
3136 /* Assign a derived type constructor to a variable.  */
3137
3138 static tree
3139 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3140 {
3141   gfc_constructor *c;
3142   gfc_component *cm;
3143   stmtblock_t block;
3144   tree field;
3145   tree tmp;
3146
3147   gfc_start_block (&block);
3148   cm = expr->ts.derived->components;
3149   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3150     {
3151       /* Skip absent members in default initializers.  */
3152       if (!c->expr)
3153         continue;
3154
3155       /* Update the type/kind of the expression if it represents either
3156          C_NULL_PTR or C_NULL_FUNPTR.  This is done here because this may
3157          be the first place reached for initializing output variables that
3158          have components of type C_PTR/C_FUNPTR that are initialized.  */
3159       if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3160           && c->expr->ts.derived->attr.is_iso_c)
3161         {
3162           c->expr->expr_type = EXPR_NULL;
3163           c->expr->ts.type = c->expr->ts.derived->ts.type;
3164           c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3165           c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3166         }
3167
3168       field = cm->backend_decl;
3169       tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3170       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3171       gfc_add_expr_to_block (&block, tmp);
3172     }
3173   return gfc_finish_block (&block);
3174 }
3175
3176 /* Build an expression for a constructor. If init is nonzero then
3177    this is part of a static variable initializer.  */
3178
3179 void
3180 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3181 {
3182   gfc_constructor *c;
3183   gfc_component *cm;
3184   tree val;
3185   tree type;
3186   tree tmp;
3187   VEC(constructor_elt,gc) *v = NULL;
3188
3189   gcc_assert (se->ss == NULL);
3190   gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3191   type = gfc_typenode_for_spec (&expr->ts);
3192
3193   if (!init)
3194     {
3195       /* Create a temporary variable and fill it in.  */
3196       se->expr = gfc_create_var (type, expr->ts.derived->name);
3197       tmp = gfc_trans_structure_assign (se->expr, expr);
3198       gfc_add_expr_to_block (&se->pre, tmp);
3199       return;
3200     }
3201
3202   cm = expr->ts.derived->components;
3203
3204   for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3205     {
3206       /* Skip absent members in default initializers and allocatable
3207          components.  Although the latter have a default initializer
3208          of EXPR_NULL,... by default, the static nullify is not needed
3209          since this is done every time we come into scope.  */
3210       if (!c->expr || cm->allocatable)
3211         continue;
3212
3213       val = gfc_conv_initializer (c->expr, &cm->ts,
3214           TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3215
3216       /* Append it to the constructor list.  */
3217       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3218     }
3219   se->expr = build_constructor (type, v);
3220 }
3221
3222
3223 /* Translate a substring expression.  */
3224
3225 static void
3226 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3227 {
3228   gfc_ref *ref;
3229
3230   ref = expr->ref;
3231
3232   gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3233
3234   se->expr = gfc_build_string_const (expr->value.character.length,
3235                                      expr->value.character.string);
3236   se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3237   TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3238
3239   if (ref)
3240     gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3241 }
3242
3243
3244 /* Entry point for expression translation.  Evaluates a scalar quantity.
3245    EXPR is the expression to be translated, and SE is the state structure if
3246    called from within the scalarized.  */
3247
3248 void
3249 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3250 {
3251   if (se->ss && se->ss->expr == expr
3252       && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3253     {
3254       /* Substitute a scalar expression evaluated outside the scalarization
3255          loop.  */
3256       se->expr = se->ss->data.scalar.expr;
3257       se->string_length = se->ss->string_length;
3258       gfc_advance_se_ss_chain (se);
3259       return;
3260     }
3261
3262   /* We need to convert the expressions for the iso_c_binding derived types.
3263      C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3264      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
3265      typespec for the C_PTR and C_FUNPTR symbols, which has already been
3266      updated to be an integer with a kind equal to the size of a (void *).  */
3267   if (expr->ts.type == BT_DERIVED && expr->ts.derived
3268       && expr->ts.derived->attr.is_iso_c)
3269     {
3270       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3271           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3272         {
3273           /* Set expr_type to EXPR_NULL, which will result in
3274              null_pointer_node being used below.  */
3275           expr->expr_type = EXPR_NULL;
3276         }
3277       else
3278         {
3279           /* Update the type/kind of the expression to be what the new
3280              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
3281           expr->ts.type = expr->ts.derived->ts.type;
3282           expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3283           expr->ts.kind = expr->ts.derived->ts.kind;
3284         }
3285     }
3286
3287   switch (expr->expr_type)
3288     {
3289     case EXPR_OP:
3290       gfc_conv_expr_op (se, expr);
3291       break;
3292
3293     case EXPR_FUNCTION:
3294       gfc_conv_function_expr (se, expr);
3295       break;
3296
3297     case EXPR_CONSTANT:
3298       gfc_conv_constant (se, expr);
3299       break;
3300
3301     case EXPR_VARIABLE:
3302       gfc_conv_variable (se, expr);
3303       break;
3304
3305     case EXPR_NULL:
3306       se->expr = null_pointer_node;
3307       break;
3308
3309     case EXPR_SUBSTRING:
3310       gfc_conv_substring_expr (se, expr);
3311       break;
3312
3313     case EXPR_STRUCTURE:
3314       gfc_conv_structure (se, expr, 0);
3315       break;
3316
3317     case EXPR_ARRAY:
3318       gfc_conv_array_constructor_expr (se, expr);
3319       break;
3320
3321     default:
3322       gcc_unreachable ();
3323       break;
3324     }
3325 }
3326
3327 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3328    of an assignment.  */
3329 void
3330 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3331 {
3332   gfc_conv_expr (se, expr);
3333   /* All numeric lvalues should have empty post chains.  If not we need to
3334      figure out a way of rewriting an lvalue so that it has no post chain.  */
3335   gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3336 }
3337
3338 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3339    numeric expressions.  Used for scalar values where inserting cleanup code
3340    is inconvenient.  */
3341 void
3342 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3343 {
3344   tree val;
3345
3346   gcc_assert (expr->ts.type != BT_CHARACTER);
3347   gfc_conv_expr (se, expr);
3348   if (se->post.head)
3349     {
3350       val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3351       gfc_add_modify_expr (&se->pre, val, se->expr);
3352       se->expr = val;
3353       gfc_add_block_to_block (&se->pre, &se->post);
3354     }
3355 }
3356
3357 /* Helper to translate and expression and convert it to a particular type.  */
3358 void
3359 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3360 {
3361   gfc_conv_expr_val (se, expr);
3362   se->expr = convert (type, se->expr);
3363 }
3364
3365
3366 /* Converts an expression so that it can be passed by reference.  Scalar
3367    values only.  */
3368
3369 void
3370 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3371 {
3372   tree var;
3373
3374   if (se->ss && se->ss->expr == expr
3375       && se->ss->type == GFC_SS_REFERENCE)
3376     {
3377       se->expr = se->ss->data.scalar.expr;
3378       se->string_length = se->ss->string_length;
3379       gfc_advance_se_ss_chain (se);
3380       return;
3381     }
3382
3383   if (expr->ts.type == BT_CHARACTER)
3384     {
3385       gfc_conv_expr (se, expr);
3386       gfc_conv_string_parameter (se);
3387       return;
3388     }
3389
3390   if (expr->expr_type == EXPR_VARIABLE)
3391     {
3392       se->want_pointer = 1;
3393       gfc_conv_expr (se, expr);
3394       if (se->post.head)
3395         {
3396           var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3397           gfc_add_modify_expr (&se->pre, var, se->expr);
3398           gfc_add_block_to_block (&se->pre, &se->post);
3399           se->expr = var;
3400         }
3401       return;
3402     }
3403
3404   if (expr->expr_type == EXPR_FUNCTION
3405         && expr->symtree->n.sym->attr.pointer
3406         && !expr->symtree->n.sym->attr.dimension)
3407     {
3408       se->want_pointer = 1;
3409       gfc_conv_expr (se, expr);
3410       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3411       gfc_add_modify_expr (&se->pre, var, se->expr);
3412       se->expr = var;
3413       return;
3414     }
3415
3416
3417   gfc_conv_expr (se, expr);
3418
3419   /* Create a temporary var to hold the value.  */
3420   if (TREE_CONSTANT (se->expr))
3421     {
3422       tree tmp = se->expr;
3423       STRIP_TYPE_NOPS (tmp);
3424       var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3425       DECL_INITIAL (var) = tmp;
3426       TREE_STATIC (var) = 1;
3427       pushdecl (var);
3428     }
3429   else
3430     {
3431       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3432       gfc_add_modify_expr (&se->pre, var, se->expr);
3433     }
3434   gfc_add_block_to_block (&se->pre, &se->post);
3435
3436   /* Take the address of that value.  */
3437   se->expr = build_fold_addr_expr (var);
3438 }
3439
3440
3441 tree
3442 gfc_trans_pointer_assign (gfc_code * code)
3443 {
3444   return gfc_trans_pointer_assignment (code->expr, code->expr2);
3445 }
3446
3447
3448 /* Generate code for a pointer assignment.  */
3449
3450 tree
3451 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3452 {
3453   gfc_se lse;
3454   gfc_se rse;
3455   gfc_ss *lss;
3456   gfc_ss *rss;
3457   stmtblock_t block;
3458   tree desc;
3459   tree tmp;
3460   tree decl;
3461
3462
3463   gfc_start_block (&block);
3464
3465   gfc_init_se (&lse, NULL);
3466
3467   lss = gfc_walk_expr (expr1);
3468   rss = gfc_walk_expr (expr2);
3469   if (lss == gfc_ss_terminator)
3470     {
3471       /* Scalar pointers.  */
3472       lse.want_pointer = 1;
3473       gfc_conv_expr (&lse, expr1);
3474       gcc_assert (rss == gfc_ss_terminator);
3475       gfc_init_se (&rse, NULL);
3476       rse.want_pointer = 1;
3477       gfc_conv_expr (&rse, expr2);
3478       gfc_add_block_to_block (&block, &lse.pre);
3479       gfc_add_block_to_block (&block, &rse.pre);
3480       gfc_add_modify_expr (&block, lse.expr,
3481                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3482       gfc_add_block_to_block (&block, &rse.post);
3483       gfc_add_block_to_block (&block, &lse.post);
3484     }
3485   else
3486     {
3487       /* Array pointer.  */
3488       gfc_conv_expr_descriptor (&lse, expr1, lss);
3489       switch (expr2->expr_type)
3490         {
3491         case EXPR_NULL:
3492           /* Just set the data pointer to null.  */
3493           gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3494           break;
3495
3496         case EXPR_VARIABLE:
3497           /* Assign directly to the pointer's descriptor.  */
3498           lse.direct_byref = 1;
3499           gfc_conv_expr_descriptor (&lse, expr2, rss);
3500
3501           /* If this is a subreference array pointer assignment, use the rhs
3502              element size for the lhs span.  */
3503           if (expr1->symtree->n.sym->attr.subref_array_pointer)
3504             {
3505               decl = expr1->symtree->n.sym->backend_decl;
3506               tmp = rss->data.info.descriptor;
3507               tmp = gfc_get_element_type (TREE_TYPE (tmp));
3508               tmp = size_in_bytes (tmp);
3509               tmp = fold_convert (gfc_array_index_type, tmp);
3510               gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
3511             }
3512
3513           break;
3514
3515         default:
3516           /* Assign to a temporary descriptor and then copy that
3517              temporary to the pointer.  */
3518           desc = lse.expr;
3519           tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3520
3521           lse.expr = tmp;
3522           lse.direct_byref = 1;
3523           gfc_conv_expr_descriptor (&lse, expr2, rss);
3524           gfc_add_modify_expr (&lse.pre, desc, tmp);
3525           break;
3526         }
3527       gfc_add_block_to_block (&block, &lse.pre);
3528       gfc_add_block_to_block (&block, &lse.post);
3529     }
3530   return gfc_finish_block (&block);
3531 }
3532
3533
3534 /* Makes sure se is suitable for passing as a function string parameter.  */
3535 /* TODO: Need to check all callers fo this function.  It may be abused.  */
3536
3537 void
3538 gfc_conv_string_parameter (gfc_se * se)
3539 {
3540   tree type;
3541
3542   if (TREE_CODE (se->expr) == STRING_CST)
3543     {
3544       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3545       return;
3546     }
3547
3548   type = TREE_TYPE (se->expr);
3549   if (TYPE_STRING_FLAG (type))
3550     {
3551       gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3552       se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3553     }
3554
3555   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3556   gcc_assert (se->string_length
3557           && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3558 }
3559
3560
3561 /* Generate code for assignment of scalar variables.  Includes character
3562    strings and derived types with allocatable components.  */
3563
3564 tree
3565 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3566                          bool l_is_temp, bool r_is_var)
3567 {
3568   stmtblock_t block;
3569   tree tmp;
3570   tree cond;
3571
3572   gfc_init_block (&block);
3573
3574   if (ts.type == BT_CHARACTER)
3575     {
3576       gcc_assert (lse->string_length != NULL_TREE
3577               && rse->string_length != NULL_TREE);
3578
3579       gfc_conv_string_parameter (lse);
3580       gfc_conv_string_parameter (rse);
3581
3582       gfc_add_block_to_block (&block, &lse->pre);
3583       gfc_add_block_to_block (&block, &rse->pre);
3584
3585       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3586                              rse->string_length, rse->expr);
3587     }
3588   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3589     {
3590       cond = NULL_TREE;
3591
3592       /* Are the rhs and the lhs the same?  */
3593       if (r_is_var)
3594         {
3595           cond = fold_build2 (EQ_EXPR, boolean_type_node,
3596                               build_fold_addr_expr (lse->expr),
3597                               build_fold_addr_expr (rse->expr));
3598           cond = gfc_evaluate_now (cond, &lse->pre);
3599         }
3600
3601       /* Deallocate the lhs allocated components as long as it is not
3602          the same as the rhs.  This must be done following the assignment
3603          to prevent deallocating data that could be used in the rhs
3604          expression.  */
3605       if (!l_is_temp)
3606         {
3607           tmp = gfc_evaluate_now (lse->expr, &lse->pre);
3608           tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
3609           if (r_is_var)
3610             tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3611           gfc_add_expr_to_block (&lse->post, tmp);
3612         }
3613
3614       gfc_add_block_to_block (&block, &rse->pre);
3615       gfc_add_block_to_block (&block, &lse->pre);
3616
3617       gfc_add_modify_expr (&block, lse->expr,
3618                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
3619
3620       /* Do a deep copy if the rhs is a variable, if it is not the
3621          same as the lhs.  */
3622       if (r_is_var)
3623         {
3624           tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3625           tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3626           gfc_add_expr_to_block (&block, tmp);
3627         }
3628     }
3629   else
3630     {
3631       gfc_add_block_to_block (&block, &lse->pre);
3632       gfc_add_block_to_block (&block, &rse->pre);
3633
3634       gfc_add_modify_expr (&block, lse->expr,
3635                            fold_convert (TREE_TYPE (lse->expr), rse->expr));
3636     }
3637
3638   gfc_add_block_to_block (&block, &lse->post);
3639   gfc_add_block_to_block (&block, &rse->post);
3640
3641   return gfc_finish_block (&block);
3642 }
3643
3644
3645 /* Try to translate array(:) = func (...), where func is a transformational
3646    array function, without using a temporary.  Returns NULL is this isn't the
3647    case.  */
3648
3649 static tree
3650 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3651 {
3652   gfc_se se;
3653   gfc_ss *ss;
3654   gfc_ref * ref;
3655   bool seen_array_ref;
3656
3657   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
3658   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3659     return NULL;
3660
3661   /* Elemental functions don't need a temporary anyway.  */
3662   if (expr2->value.function.esym != NULL
3663       && expr2->value.function.esym->attr.elemental)
3664     return NULL;
3665
3666   /* Fail if EXPR1 can't be expressed as a descriptor.  */
3667   if (gfc_ref_needs_temporary_p (expr1->ref))
3668     return NULL;
3669
3670   /* Functions returning pointers need temporaries.  */
3671   if (expr2->symtree->n.sym->attr.pointer
3672       || expr2->symtree->n.sym->attr.allocatable)
3673     return NULL;
3674
3675   /* Character array functions need temporaries unless the
3676      character lengths are the same.  */
3677   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3678     {
3679       if (expr1->ts.cl->length == NULL
3680             || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3681         return NULL;
3682
3683       if (expr2->ts.cl->length == NULL
3684             || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3685         return NULL;
3686
3687       if (mpz_cmp (expr1->ts.cl->length->value.integer,
3688                      expr2->ts.cl->length->value.integer) != 0)
3689         return NULL;
3690     }
3691
3692   /* Check that no LHS component references appear during an array
3693      reference. This is needed because we do not have the means to
3694      span any arbitrary stride with an array descriptor. This check
3695      is not needed for the rhs because the function result has to be
3696      a complete type.  */
3697   seen_array_ref = false;
3698   for (ref = expr1->ref; ref; ref = ref->next)
3699     {
3700       if (ref->type == REF_ARRAY)
3701         seen_array_ref= true;
3702       else if (ref->type == REF_COMPONENT && seen_array_ref)
3703         return NULL;
3704     }
3705
3706   /* Check for a dependency.  */
3707   if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3708                                    expr2->value.function.esym,
3709                                    expr2->value.function.actual))
3710     return NULL;
3711
3712   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3713      functions.  */
3714   gcc_assert (expr2->value.function.isym
3715               || (gfc_return_by_reference (expr2->value.function.esym)
3716               && expr2->value.function.esym->result->attr.dimension));
3717
3718   ss = gfc_walk_expr (expr1);
3719   gcc_assert (ss != gfc_ss_terminator);
3720   gfc_init_se (&se, NULL);
3721   gfc_start_block (&se.pre);
3722   se.want_pointer = 1;
3723
3724   gfc_conv_array_parameter (&se, expr1, ss, 0);
3725
3726   se.direct_byref = 1;
3727   se.ss = gfc_walk_expr (expr2);
3728   gcc_assert (se.ss != gfc_ss_terminator);
3729   gfc_conv_function_expr (&se, expr2);
3730   gfc_add_block_to_block (&se.pre, &se.post);
3731
3732   return gfc_finish_block (&se.pre);
3733 }
3734
3735 /* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
3736
3737 static bool
3738 is_zero_initializer_p (gfc_expr * expr)
3739 {
3740   if (expr->expr_type != EXPR_CONSTANT)
3741     return false;
3742
3743   /* We ignore constants with prescribed memory representations for now.  */
3744   if (expr->representation.string)
3745     return false;
3746
3747   switch (expr->ts.type)
3748     {
3749     case BT_INTEGER:
3750       return mpz_cmp_si (expr->value.integer, 0) == 0;
3751
3752     case BT_REAL:
3753       return mpfr_zero_p (expr->value.real)
3754              && MPFR_SIGN (expr->value.real) >= 0;
3755
3756     case BT_LOGICAL:
3757       return expr->value.logical == 0;
3758
3759     case BT_COMPLEX:
3760       return mpfr_zero_p (expr->value.complex.r)
3761              && MPFR_SIGN (expr->value.complex.r) >= 0
3762              && mpfr_zero_p (expr->value.complex.i)
3763              && MPFR_SIGN (expr->value.complex.i) >= 0;
3764
3765     default:
3766       break;
3767     }
3768   return false;
3769 }
3770
3771 /* Try to efficiently translate array(:) = 0.  Return NULL if this
3772    can't be done.  */
3773
3774 static tree
3775 gfc_trans_zero_assign (gfc_expr * expr)
3776 {
3777   tree dest, len, type;
3778   tree tmp;
3779   gfc_symbol *sym;
3780
3781   sym = expr->symtree->n.sym;
3782   dest = gfc_get_symbol_decl (sym);
3783
3784   type = TREE_TYPE (dest);
3785   if (POINTER_TYPE_P (type))
3786     type = TREE_TYPE (type);
3787   if (!GFC_ARRAY_TYPE_P (type))
3788     return NULL_TREE;
3789
3790   /* Determine the length of the array.  */
3791   len = GFC_TYPE_ARRAY_SIZE (type);
3792   if (!len || TREE_CODE (len) != INTEGER_CST)
3793     return NULL_TREE;
3794
3795   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3796   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3797                      fold_convert (gfc_array_index_type, tmp));
3798
3799   /* Convert arguments to the correct types.  */
3800   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3801     dest = gfc_build_addr_expr (pvoid_type_node, dest);
3802   else
3803     dest = fold_convert (pvoid_type_node, dest);
3804   len = fold_convert (size_type_node, len);
3805
3806   /* Construct call to __builtin_memset.  */
3807   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3808                          3, dest, integer_zero_node, len);
3809   return fold_convert (void_type_node, tmp);
3810 }
3811
3812
3813 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3814    that constructs the call to __builtin_memcpy.  */
3815
3816 static tree
3817 gfc_build_memcpy_call (tree dst, tree src, tree len)
3818 {
3819   tree tmp;
3820
3821   /* Convert arguments to the correct types.  */
3822   if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3823     dst = gfc_build_addr_expr (pvoid_type_node, dst);
3824   else
3825     dst = fold_convert (pvoid_type_node, dst);
3826
3827   if (!POINTER_TYPE_P (TREE_TYPE (src)))
3828     src = gfc_build_addr_expr (pvoid_type_node, src);
3829   else
3830     src = fold_convert (pvoid_type_node, src);
3831
3832   len = fold_convert (size_type_node, len);
3833
3834   /* Construct call to __builtin_memcpy.  */
3835   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3836   return fold_convert (void_type_node, tmp);
3837 }
3838
3839
3840 /* Try to efficiently translate dst(:) = src(:).  Return NULL if this
3841    can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
3842    source/rhs, both are gfc_full_array_ref_p which have been checked for
3843    dependencies.  */
3844
3845 static tree
3846 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3847 {
3848   tree dst, dlen, dtype;
3849   tree src, slen, stype;
3850   tree tmp;
3851
3852   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3853   src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3854
3855   dtype = TREE_TYPE (dst);
3856   if (POINTER_TYPE_P (dtype))
3857     dtype = TREE_TYPE (dtype);
3858   stype = TREE_TYPE (src);
3859   if (POINTER_TYPE_P (stype))
3860     stype = TREE_TYPE (stype);
3861
3862   if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3863     return NULL_TREE;
3864
3865   /* Determine the lengths of the arrays.  */
3866   dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3867   if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3868     return NULL_TREE;
3869   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3870   dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3871                       fold_convert (gfc_array_index_type, tmp));
3872
3873   slen = GFC_TYPE_ARRAY_SIZE (stype);
3874   if (!slen || TREE_CODE (slen) != INTEGER_CST)
3875     return NULL_TREE;
3876   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
3877   slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3878                       fold_convert (gfc_array_index_type, tmp));
3879
3880   /* Sanity check that they are the same.  This should always be
3881      the case, as we should already have checked for conformance.  */
3882   if (!tree_int_cst_equal (slen, dlen))
3883     return NULL_TREE;
3884
3885   return gfc_build_memcpy_call (dst, src, dlen);
3886 }
3887
3888
3889 /* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
3890    this can't be done.  EXPR1 is the destination/lhs for which
3891    gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
3892
3893 static tree
3894 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3895 {
3896   unsigned HOST_WIDE_INT nelem;
3897   tree dst, dtype;
3898   tree src, stype;
3899   tree len;
3900   tree tmp;
3901
3902   nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3903   if (nelem == 0)
3904     return NULL_TREE;
3905
3906   dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3907   dtype = TREE_TYPE (dst);
3908   if (POINTER_TYPE_P (dtype))
3909     dtype = TREE_TYPE (dtype);
3910   if (!GFC_ARRAY_TYPE_P (dtype))
3911     return NULL_TREE;
3912
3913   /* Determine the lengths of the array.  */
3914   len = GFC_TYPE_ARRAY_SIZE (dtype);
3915   if (!len || TREE_CODE (len) != INTEGER_CST)
3916     return NULL_TREE;
3917
3918   /* Confirm that the constructor is the same size.  */
3919   if (compare_tree_int (len, nelem) != 0)
3920     return NULL_TREE;
3921
3922   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3923   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3924                      fold_convert (gfc_array_index_type, tmp));
3925
3926   stype = gfc_typenode_for_spec (&expr2->ts);
3927   src = gfc_build_constant_array_constructor (expr2, stype);
3928
3929   stype = TREE_TYPE (src);
3930   if (POINTER_TYPE_P (stype))
3931     stype = TREE_TYPE (stype);
3932
3933   return gfc_build_memcpy_call (dst, src, len);
3934 }
3935
3936
3937 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3938    assignment.  EXPR1 is the destination/RHS and EXPR2 is the source/LHS.  */
3939
3940 static tree
3941 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3942 {
3943   gfc_se lse;
3944   gfc_se rse;
3945   gfc_ss *lss;
3946   gfc_ss *lss_section;
3947   gfc_ss *rss;
3948   gfc_loopinfo loop;
3949   tree tmp;
3950   stmtblock_t block;
3951   stmtblock_t body;
3952   bool l_is_temp;
3953
3954   /* Assignment of the form lhs = rhs.  */
3955   gfc_start_block (&block);
3956
3957   gfc_init_se (&lse, NULL);
3958   gfc_init_se (&rse, NULL);
3959
3960   /* Walk the lhs.  */
3961   lss = gfc_walk_expr (expr1);
3962   rss = NULL;
3963   if (lss != gfc_ss_terminator)
3964     {
3965       /* The assignment needs scalarization.  */
3966       lss_section = lss;
3967
3968       /* Find a non-scalar SS from the lhs.  */
3969       while (lss_section != gfc_ss_terminator
3970              && lss_section->type != GFC_SS_SECTION)
3971         lss_section = lss_section->next;
3972
3973       gcc_assert (lss_section != gfc_ss_terminator);
3974
3975       /* Initialize the scalarizer.  */
3976       gfc_init_loopinfo (&loop);
3977
3978       /* Walk the rhs.  */
3979       rss = gfc_walk_expr (expr2);
3980       if (rss == gfc_ss_terminator)
3981         {
3982           /* The rhs is scalar.  Add a ss for the expression.  */
3983           rss = gfc_get_ss ();
3984           rss->next = gfc_ss_terminator;
3985           rss->type = GFC_SS_SCALAR;
3986           rss->expr = expr2;
3987         }
3988       /* Associate the SS with the loop.  */
3989       gfc_add_ss_to_loop (&loop, lss);
3990       gfc_add_ss_to_loop (&loop, rss);
3991
3992       /* Calculate the bounds of the scalarization.  */
3993       gfc_conv_ss_startstride (&loop);
3994       /* Resolve any data dependencies in the statement.  */
3995       gfc_conv_resolve_dependencies (&loop, lss, rss);
3996       /* Setup the scalarizing loops.  */
3997       gfc_conv_loop_setup (&loop);
3998
3999       /* Setup the gfc_se structures.  */
4000       gfc_copy_loopinfo_to_se (&lse, &loop);
4001       gfc_copy_loopinfo_to_se (&rse, &loop);
4002
4003       rse.ss = rss;
4004       gfc_mark_ss_chain_used (rss, 1);
4005       if (loop.temp_ss == NULL)
4006         {
4007           lse.ss = lss;
4008           gfc_mark_ss_chain_used (lss, 1);
4009         }
4010       else
4011         {
4012           lse.ss = loop.temp_ss;
4013           gfc_mark_ss_chain_used (lss, 3);
4014           gfc_mark_ss_chain_used (loop.temp_ss, 3);
4015         }
4016
4017       /* Start the scalarized loop body.  */
4018       gfc_start_scalarized_body (&loop, &body);
4019     }
4020   else
4021     gfc_init_block (&body);
4022
4023   l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4024
4025   /* Translate the expression.  */
4026   gfc_conv_expr (&rse, expr2);
4027
4028   if (l_is_temp)
4029     {
4030       gfc_conv_tmp_array_ref (&lse);
4031       gfc_advance_se_ss_chain (&lse);
4032     }
4033   else
4034     gfc_conv_expr (&lse, expr1);
4035
4036   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4037                                  l_is_temp || init_flag,
4038                                  expr2->expr_type == EXPR_VARIABLE);
4039   gfc_add_expr_to_block (&body, tmp);
4040
4041   if (lss == gfc_ss_terminator)
4042     {
4043       /* Use the scalar assignment as is.  */
4044       gfc_add_block_to_block (&block, &body);
4045     }
4046   else
4047     {
4048       gcc_assert (lse.ss == gfc_ss_terminator
4049                   && rse.ss == gfc_ss_terminator);
4050
4051       if (l_is_temp)
4052         {
4053           gfc_trans_scalarized_loop_boundary (&loop, &body);
4054
4055           /* We need to copy the temporary to the actual lhs.  */
4056           gfc_init_se (&lse, NULL);
4057           gfc_init_se (&rse, NULL);
4058           gfc_copy_loopinfo_to_se (&lse, &loop);
4059           gfc_copy_loopinfo_to_se (&rse, &loop);
4060
4061           rse.ss = loop.temp_ss;
4062           lse.ss = lss;
4063
4064           gfc_conv_tmp_array_ref (&rse);
4065           gfc_advance_se_ss_chain (&rse);
4066           gfc_conv_expr (&lse, expr1);
4067
4068           gcc_assert (lse.ss == gfc_ss_terminator
4069                       && rse.ss == gfc_ss_terminator);
4070
4071           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4072                                          false, false);
4073           gfc_add_expr_to_block (&body, tmp);
4074         }
4075
4076       /* Generate the copying loops.  */
4077       gfc_trans_scalarizing_loops (&loop, &body);
4078
4079       /* Wrap the whole thing up.  */
4080       gfc_add_block_to_block (&block, &loop.pre);
4081       gfc_add_block_to_block (&block, &loop.post);
4082
4083       gfc_cleanup_loop (&loop);
4084     }
4085
4086   return gfc_finish_block (&block);
4087 }
4088
4089
4090 /* Check whether EXPR is a copyable array.  */
4091
4092 static bool
4093 copyable_array_p (gfc_expr * expr)
4094 {
4095   if (expr->expr_type != EXPR_VARIABLE)
4096     return false;
4097
4098   /* First check it's an array.  */
4099   if (expr->rank < 1 || !expr->ref || expr->ref->next)
4100     return false;
4101
4102   if (!gfc_full_array_ref_p (expr->ref))
4103     return false;
4104
4105   /* Next check that it's of a simple enough type.  */
4106   switch (expr->ts.type)
4107     {
4108     case BT_INTEGER:
4109     case BT_REAL:
4110     case BT_COMPLEX:
4111     case BT_LOGICAL:
4112       return true;
4113
4114     case BT_CHARACTER:
4115       return false;
4116
4117     case BT_DERIVED:
4118       return !expr->ts.derived->attr.alloc_comp;
4119
4120     default:
4121       break;
4122     }
4123
4124   return false;
4125 }
4126
4127 /* Translate an assignment.  */
4128
4129 tree
4130 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4131 {
4132   tree tmp;
4133
4134   /* Special case a single function returning an array.  */
4135   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4136     {
4137       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4138       if (tmp)
4139         return tmp;
4140     }
4141
4142   /* Special case assigning an array to zero.  */
4143   if (copyable_array_p (expr1)
4144       && is_zero_initializer_p (expr2))
4145     {
4146       tmp = gfc_trans_zero_assign (expr1);
4147       if (tmp)
4148         return tmp;
4149     }
4150
4151   /* Special case copying one array to another.  */
4152   if (copyable_array_p (expr1)
4153       && copyable_array_p (expr2)
4154       && gfc_compare_types (&expr1->ts, &expr2->ts)
4155       && !gfc_check_dependency (expr1, expr2, 0))
4156     {
4157       tmp = gfc_trans_array_copy (expr1, expr2);
4158       if (tmp)
4159         return tmp;
4160     }
4161
4162   /* Special case initializing an array from a constant array constructor.  */
4163   if (copyable_array_p (expr1)
4164       && expr2->expr_type == EXPR_ARRAY
4165       && gfc_compare_types (&expr1->ts, &expr2->ts))
4166     {
4167       tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4168       if (tmp)
4169         return tmp;
4170     }
4171
4172   /* Fallback to the scalarizer to generate explicit loops.  */
4173   return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4174 }
4175
4176 tree
4177 gfc_trans_init_assign (gfc_code * code)
4178 {
4179   return gfc_trans_assignment (code->expr, code->expr2, true);
4180 }
4181
4182 tree
4183 gfc_trans_assign (gfc_code * code)
4184 {
4185   return gfc_trans_assignment (code->expr, code->expr2, false);
4186 }