gcc/fortran/trans-expr.c

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