gcc/fortran/trans-expr.c

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