gcc/fortran/trans-expr.c

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