gcc/fortran/trans-expr.c

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