gcc/fortran/trans-expr.c

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