gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002-2014 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "coretypes.h"
  24 #include "gfortran.h"
  25 #include "tree.h"
  26 #include "gimple-expr.h"        /* For create_tmp_var_raw.  */
  27 #include "stringpool.h"
  28 #include "tree-iterator.h"
  29 #include "diagnostic-core.h"  /* For internal_error.  */
  30 #include "flags.h"
  31 #include "trans.h"
  32 #include "trans-stmt.h"
  33 #include "trans-array.h"
  34 #include "trans-types.h"
  35 #include "trans-const.h"
  36
  37 /* Naming convention for backend interface code:
  38
  39    gfc_trans_*  translate gfc_code into STMT trees.
  40
  41    gfc_conv_*   expression conversion
  42
  43    gfc_get_*    get a backend tree representation of a decl or type  */
  44
  45 static gfc_file *gfc_current_backend_file;
  46
  47 const char gfc_msg_fault[] = N_("Array reference out of bounds");
  48 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  49
  50
  51 /* Advance along TREE_CHAIN n times.  */
  52
  53 tree
  54 gfc_advance_chain (tree t, int n)
  55 {
  56   for (; n > 0; n--)
  57     {
  58       gcc_assert (t != NULL_TREE);
  59       t = DECL_CHAIN (t);
  60     }
  61   return t;
  62 }
  63
  64
  65 /* Strip off a legitimate source ending from the input
  66    string NAME of length LEN.  */
  67
  68 static inline void
  69 remove_suffix (char *name, int len)
  70 {
  71   int i;
  72
  73   for (i = 2; i < 8 && len > i; i++)
  74     {
  75       if (name[len - i] == '.')
  76         {
  77           name[len - i] = '\0';
  78           break;
  79         }
  80     }
  81 }
  82
  83
  84 /* Creates a variable declaration with a given TYPE.  */
  85
  86 tree
  87 gfc_create_var_np (tree type, const char *prefix)
  88 {
  89   tree t;
  90
  91   t = create_tmp_var_raw (type, prefix);
  92
  93   /* No warnings for anonymous variables.  */
  94   if (prefix == NULL)
  95     TREE_NO_WARNING (t) = 1;
  96
  97   return t;
  98 }
  99
 100
 101 /* Like above, but also adds it to the current scope.  */
 102
 103 tree
 104 gfc_create_var (tree type, const char *prefix)
 105 {
 106   tree tmp;
 107
 108   tmp = gfc_create_var_np (type, prefix);
 109
 110   pushdecl (tmp);
 111
 112   return tmp;
 113 }
 114
 115
 116 /* If the expression is not constant, evaluate it now.  We assign the
 117    result of the expression to an artificially created variable VAR, and
 118    return a pointer to the VAR_DECL node for this variable.  */
 119
 120 tree
 121 gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
 122 {
 123   tree var;
 124
 125   if (CONSTANT_CLASS_P (expr))
 126     return expr;
 127
 128   var = gfc_create_var (TREE_TYPE (expr), NULL);
 129   gfc_add_modify_loc (loc, pblock, var, expr);
 130
 131   return var;
 132 }
 133
 134
 135 tree
 136 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 137 {
 138   return gfc_evaluate_now_loc (input_location, expr, pblock);
 139 }
 140
 141
 142 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 143    A MODIFY_EXPR is an assignment:
 144    LHS <- RHS.  */
 145
 146 void
 147 gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
 148 {
 149   tree tmp;
 150
 151 #ifdef ENABLE_CHECKING
 152   tree t1, t2;
 153   t1 = TREE_TYPE (rhs);
 154   t2 = TREE_TYPE (lhs);
 155   /* Make sure that the types of the rhs and the lhs are the same
 156      for scalar assignments.  We should probably have something
 157      similar for aggregates, but right now removing that check just
 158      breaks everything.  */
 159   gcc_assert (t1 == t2
 160               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 161 #endif
 162
 163   tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
 164                          rhs);
 165   gfc_add_expr_to_block (pblock, tmp);
 166 }
 167
 168
 169 void
 170 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 171 {
 172   gfc_add_modify_loc (input_location, pblock, lhs, rhs);
 173 }
 174
 175
 176 /* Create a new scope/binding level and initialize a block.  Care must be
 177    taken when translating expressions as any temporaries will be placed in
 178    the innermost scope.  */
 179
 180 void
 181 gfc_start_block (stmtblock_t * block)
 182 {
 183   /* Start a new binding level.  */
 184   pushlevel ();
 185   block->has_scope = 1;
 186
 187   /* The block is empty.  */
 188   block->head = NULL_TREE;
 189 }
 190
 191
 192 /* Initialize a block without creating a new scope.  */
 193
 194 void
 195 gfc_init_block (stmtblock_t * block)
 196 {
 197   block->head = NULL_TREE;
 198   block->has_scope = 0;
 199 }
 200
 201
 202 /* Sometimes we create a scope but it turns out that we don't actually
 203    need it.  This function merges the scope of BLOCK with its parent.
 204    Only variable decls will be merged, you still need to add the code.  */
 205
 206 void
 207 gfc_merge_block_scope (stmtblock_t * block)
 208 {
 209   tree decl;
 210   tree next;
 211
 212   gcc_assert (block->has_scope);
 213   block->has_scope = 0;
 214
 215   /* Remember the decls in this scope.  */
 216   decl = getdecls ();
 217   poplevel (0, 0);
 218
 219   /* Add them to the parent scope.  */
 220   while (decl != NULL_TREE)
 221     {
 222       next = DECL_CHAIN (decl);
 223       DECL_CHAIN (decl) = NULL_TREE;
 224
 225       pushdecl (decl);
 226       decl = next;
 227     }
 228 }
 229
 230
 231 /* Finish a scope containing a block of statements.  */
 232
 233 tree
 234 gfc_finish_block (stmtblock_t * stmtblock)
 235 {
 236   tree decl;
 237   tree expr;
 238   tree block;
 239
 240   expr = stmtblock->head;
 241   if (!expr)
 242     expr = build_empty_stmt (input_location);
 243
 244   stmtblock->head = NULL_TREE;
 245
 246   if (stmtblock->has_scope)
 247     {
 248       decl = getdecls ();
 249
 250       if (decl)
 251         {
 252           block = poplevel (1, 0);
 253           expr = build3_v (BIND_EXPR, decl, expr, block);
 254         }
 255       else
 256         poplevel (0, 0);
 257     }
 258
 259   return expr;
 260 }
 261
 262
 263 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 264    natural type is used.  */
 265
 266 tree
 267 gfc_build_addr_expr (tree type, tree t)
 268 {
 269   tree base_type = TREE_TYPE (t);
 270   tree natural_type;
 271
 272   if (type && POINTER_TYPE_P (type)
 273       && TREE_CODE (base_type) == ARRAY_TYPE
 274       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 275          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 276     {
 277       tree min_val = size_zero_node;
 278       tree type_domain = TYPE_DOMAIN (base_type);
 279       if (type_domain && TYPE_MIN_VALUE (type_domain))
 280         min_val = TYPE_MIN_VALUE (type_domain);
 281       t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
 282                             t, min_val, NULL_TREE, NULL_TREE));
 283       natural_type = type;
 284     }
 285   else
 286     natural_type = build_pointer_type (base_type);
 287
 288   if (TREE_CODE (t) == INDIRECT_REF)
 289     {
 290       if (!type)
 291         type = natural_type;
 292       t = TREE_OPERAND (t, 0);
 293       natural_type = TREE_TYPE (t);
 294     }
 295   else
 296     {
 297       tree base = get_base_address (t);
 298       if (base && DECL_P (base))
 299         TREE_ADDRESSABLE (base) = 1;
 300       t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
 301     }
 302
 303   if (type && natural_type != type)
 304     t = convert (type, t);
 305
 306   return t;
 307 }
 308
 309
 310 /* Build an ARRAY_REF with its natural type.  */
 311
 312 tree
 313 gfc_build_array_ref (tree base, tree offset, tree decl)
 314 {
 315   tree type = TREE_TYPE (base);
 316   tree tmp;
 317   tree span;
 318
 319   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
 320     {
 321       gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
 322
 323       return fold_convert (TYPE_MAIN_VARIANT (type), base);
 324     }
 325
 326   /* Scalar coarray, there is nothing to do.  */
 327   if (TREE_CODE (type) != ARRAY_TYPE)
 328     {
 329       gcc_assert (decl == NULL_TREE);
 330       gcc_assert (integer_zerop (offset));
 331       return base;
 332     }
 333
 334   type = TREE_TYPE (type);
 335
 336   if (DECL_P (base))
 337     TREE_ADDRESSABLE (base) = 1;
 338
 339   /* Strip NON_LVALUE_EXPR nodes.  */
 340   STRIP_TYPE_NOPS (offset);
 341
 342   /* If the array reference is to a pointer, whose target contains a
 343      subreference, use the span that is stored with the backend decl
 344      and reference the element with pointer arithmetic.  */
 345   if (decl && (TREE_CODE (decl) == FIELD_DECL
 346                  || TREE_CODE (decl) == VAR_DECL
 347                  || TREE_CODE (decl) == PARM_DECL)
 348         && ((GFC_DECL_SUBREF_ARRAY_P (decl)
 349               && !integer_zerop (GFC_DECL_SPAN(decl)))
 350            || GFC_DECL_CLASS (decl)))
 351     {
 352       if (GFC_DECL_CLASS (decl))
 353         {
 354           /* Allow for dummy arguments and other good things.  */
 355           if (POINTER_TYPE_P (TREE_TYPE (decl)))
 356             decl = build_fold_indirect_ref_loc (input_location, decl);
 357
 358           /* Check if '_data' is an array descriptor. If it is not,
 359              the array must be one of the components of the class object,
 360              so return a normal array reference.  */
 361           if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
 362             return build4_loc (input_location, ARRAY_REF, type, base,
 363                                offset, NULL_TREE, NULL_TREE);
 364
 365           span = gfc_vtable_size_get (decl);
 366         }
 367       else if (GFC_DECL_SUBREF_ARRAY_P (decl))
 368         span = GFC_DECL_SPAN(decl);
 369       else
 370         gcc_unreachable ();
 371
 372       offset = fold_build2_loc (input_location, MULT_EXPR,
 373                                 gfc_array_index_type,
 374                                 offset, span);
 375       tmp = gfc_build_addr_expr (pvoid_type_node, base);
 376       tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
 377       tmp = fold_convert (build_pointer_type (type), tmp);
 378       if (!TYPE_STRING_FLAG (type))
 379         tmp = build_fold_indirect_ref_loc (input_location, tmp);
 380       return tmp;
 381     }
 382   else
 383     /* Otherwise use a straightforward array reference.  */
 384     return build4_loc (input_location, ARRAY_REF, type, base, offset,
 385                        NULL_TREE, NULL_TREE);
 386 }
 387
 388
 389 /* Generate a call to print a runtime error possibly including multiple
 390    arguments and a locus.  */
 391
 392 static tree
 393 trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
 394                             va_list ap)
 395 {
 396   stmtblock_t block;
 397   tree tmp;
 398   tree arg, arg2;
 399   tree *argarray;
 400   tree fntype;
 401   char *message;
 402   const char *p;
 403   int line, nargs, i;
 404   location_t loc;
 405
 406   /* Compute the number of extra arguments from the format string.  */
 407   for (p = msgid, nargs = 0; *p; p++)
 408     if (*p == '%')
 409       {
 410         p++;
 411         if (*p != '%')
 412           nargs++;
 413       }
 414
 415   /* The code to generate the error.  */
 416   gfc_start_block (&block);
 417
 418   if (where)
 419     {
 420       line = LOCATION_LINE (where->lb->location);
 421       asprintf (&message, "At line %d of file %s",  line,
 422                 where->lb->file->filename);
 423     }
 424   else
 425     asprintf (&message, "In file '%s', around line %d",
 426               gfc_source_file, LOCATION_LINE (input_location) + 1);
 427
 428   arg = gfc_build_addr_expr (pchar_type_node,
 429                              gfc_build_localized_cstring_const (message));
 430   free (message);
 431
 432   asprintf (&message, "%s", _(msgid));
 433   arg2 = gfc_build_addr_expr (pchar_type_node,
 434                               gfc_build_localized_cstring_const (message));
 435   free (message);
 436
 437   /* Build the argument array.  */
 438   argarray = XALLOCAVEC (tree, nargs + 2);
 439   argarray[0] = arg;
 440   argarray[1] = arg2;
 441   for (i = 0; i < nargs; i++)
 442     argarray[2 + i] = va_arg (ap, tree);
 443
 444   /* Build the function call to runtime_(warning,error)_at; because of the
 445      variable number of arguments, we can't use build_call_expr_loc dinput_location,
 446      irectly.  */
 447   if (error)
 448     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 449   else
 450     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 451
 452   loc = where ? where->lb->location : input_location;
 453   tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
 454                                    fold_build1_loc (loc, ADDR_EXPR,
 455                                              build_pointer_type (fntype),
 456                                              error
 457                                              ? gfor_fndecl_runtime_error_at
 458                                              : gfor_fndecl_runtime_warning_at),
 459                                    nargs + 2, argarray);
 460   gfc_add_expr_to_block (&block, tmp);
 461
 462   return gfc_finish_block (&block);
 463 }
 464
 465
 466 tree
 467 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
 468 {
 469   va_list ap;
 470   tree result;
 471
 472   va_start (ap, msgid);
 473   result = trans_runtime_error_vararg (error, where, msgid, ap);
 474   va_end (ap);
 475   return result;
 476 }
 477
 478
 479 /* Generate a runtime error if COND is true.  */
 480
 481 void
 482 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 483                          locus * where, const char * msgid, ...)
 484 {
 485   va_list ap;
 486   stmtblock_t block;
 487   tree body;
 488   tree tmp;
 489   tree tmpvar = NULL;
 490
 491   if (integer_zerop (cond))
 492     return;
 493
 494   if (once)
 495     {
 496        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
 497        TREE_STATIC (tmpvar) = 1;
 498        DECL_INITIAL (tmpvar) = boolean_true_node;
 499        gfc_add_expr_to_block (pblock, tmpvar);
 500     }
 501
 502   gfc_start_block (&block);
 503
 504   /* For error, runtime_error_at already implies PRED_NORETURN.  */
 505   if (!error && once)
 506     gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
 507                                                        NOT_TAKEN));
 508
 509   /* The code to generate the error.  */
 510   va_start (ap, msgid);
 511   gfc_add_expr_to_block (&block,
 512                          trans_runtime_error_vararg (error, where,
 513                                                      msgid, ap));
 514   va_end (ap);
 515
 516   if (once)
 517     gfc_add_modify (&block, tmpvar, boolean_false_node);
 518
 519   body = gfc_finish_block (&block);
 520
 521   if (integer_onep (cond))
 522     {
 523       gfc_add_expr_to_block (pblock, body);
 524     }
 525   else
 526     {
 527       if (once)
 528         cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
 529                                 long_integer_type_node, tmpvar, cond);
 530       else
 531         cond = fold_convert (long_integer_type_node, cond);
 532
 533       tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
 534                              cond, body,
 535                              build_empty_stmt (where->lb->location));
 536       gfc_add_expr_to_block (pblock, tmp);
 537     }
 538 }
 539
 540
 541 /* Call malloc to allocate size bytes of memory, with special conditions:
 542       + if size == 0, return a malloced area of size 1,
 543       + if malloc returns NULL, issue a runtime error.  */
 544 tree
 545 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 546 {
 547   tree tmp, msg, malloc_result, null_result, res, malloc_tree;
 548   stmtblock_t block2;
 549
 550   size = gfc_evaluate_now (size, block);
 551
 552   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 553     size = fold_convert (size_type_node, size);
 554
 555   /* Create a variable to hold the result.  */
 556   res = gfc_create_var (prvoid_type_node, NULL);
 557
 558   /* Call malloc.  */
 559   gfc_start_block (&block2);
 560
 561   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
 562                           build_int_cst (size_type_node, 1));
 563
 564   malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
 565   gfc_add_modify (&block2, res,
 566                   fold_convert (prvoid_type_node,
 567                                 build_call_expr_loc (input_location,
 568                                                      malloc_tree, 1, size)));
 569
 570   /* Optionally check whether malloc was successful.  */
 571   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
 572     {
 573       null_result = fold_build2_loc (input_location, EQ_EXPR,
 574                                      boolean_type_node, res,
 575                                      build_int_cst (pvoid_type_node, 0));
 576       msg = gfc_build_addr_expr (pchar_type_node,
 577               gfc_build_localized_cstring_const ("Memory allocation failed"));
 578       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 579                              null_result,
 580               build_call_expr_loc (input_location,
 581                                    gfor_fndecl_os_error, 1, msg),
 582                                    build_empty_stmt (input_location));
 583       gfc_add_expr_to_block (&block2, tmp);
 584     }
 585
 586   malloc_result = gfc_finish_block (&block2);
 587
 588   gfc_add_expr_to_block (block, malloc_result);
 589
 590   if (type != NULL)
 591     res = fold_convert (type, res);
 592   return res;
 593 }
 594
 595
 596 /* Allocate memory, using an optional status argument.
 597
 598    This function follows the following pseudo-code:
 599
 600     void *
 601     allocate (size_t size, integer_type stat)
 602     {
 603       void *newmem;
 604
 605       if (stat requested)
 606         stat = 0;
 607
 608       newmem = malloc (MAX (size, 1));
 609       if (newmem == NULL)
 610       {
 611         if (stat)
 612           *stat = LIBERROR_ALLOCATION;
 613         else
 614           runtime_error ("Allocation would exceed memory limit");
 615       }
 616       return newmem;
 617     }  */
 618 void
 619 gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
 620                            tree size, tree status)
 621 {
 622   tree tmp, error_cond;
 623   stmtblock_t on_error;
 624   tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
 625
 626   /* Evaluate size only once, and make sure it has the right type.  */
 627   size = gfc_evaluate_now (size, block);
 628   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 629     size = fold_convert (size_type_node, size);
 630
 631   /* If successful and stat= is given, set status to 0.  */
 632   if (status != NULL_TREE)
 633       gfc_add_expr_to_block (block,
 634              fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 635                               status, build_int_cst (status_type, 0)));
 636
 637   /* The allocation itself.  */
 638   gfc_add_modify (block, pointer,
 639           fold_convert (TREE_TYPE (pointer),
 640                 build_call_expr_loc (input_location,
 641                              builtin_decl_explicit (BUILT_IN_MALLOC), 1,
 642                              fold_build2_loc (input_location,
 643                                       MAX_EXPR, size_type_node, size,
 644                                       build_int_cst (size_type_node, 1)))));
 645
 646   /* What to do in case of error.  */
 647   gfc_start_block (&on_error);
 648   if (status != NULL_TREE)
 649     {
 650       gfc_add_expr_to_block (&on_error,
 651                              build_predict_expr (PRED_FORTRAN_FAIL_ALLOC,
 652                                                  NOT_TAKEN));
 653       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
 654                              build_int_cst (status_type, LIBERROR_ALLOCATION));
 655       gfc_add_expr_to_block (&on_error, tmp);
 656     }
 657   else
 658     {
 659       /* Here, os_error already implies PRED_NORETURN.  */
 660       tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
 661                     gfc_build_addr_expr (pchar_type_node,
 662                                  gfc_build_localized_cstring_const
 663                                     ("Allocation would exceed memory limit")));
 664       gfc_add_expr_to_block (&on_error, tmp);
 665     }
 666
 667   error_cond = fold_build2_loc (input_location, EQ_EXPR,
 668                                 boolean_type_node, pointer,
 669                                 build_int_cst (prvoid_type_node, 0));
 670   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 671                          error_cond, gfc_finish_block (&on_error),
 672                          build_empty_stmt (input_location));
 673
 674   gfc_add_expr_to_block (block, tmp);
 675 }
 676
 677
 678 /* Allocate memory, using an optional status argument.
 679
 680    This function follows the following pseudo-code:
 681
 682     void *
 683     allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
 684     {
 685       void *newmem;
 686
 687       newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
 688       return newmem;
 689     }  */
 690 static void
 691 gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
 692                         tree token, tree status, tree errmsg, tree errlen)
 693 {
 694   tree tmp, pstat;
 695
 696   gcc_assert (token != NULL_TREE);
 697
 698   /* Evaluate size only once, and make sure it has the right type.  */
 699   size = gfc_evaluate_now (size, block);
 700   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 701     size = fold_convert (size_type_node, size);
 702
 703   /* The allocation itself.  */
 704   if (status == NULL_TREE)
 705     pstat  = null_pointer_node;
 706   else
 707     pstat  = gfc_build_addr_expr (NULL_TREE, status);
 708
 709   if (errmsg == NULL_TREE)
 710     {
 711       gcc_assert(errlen == NULL_TREE);
 712       errmsg = null_pointer_node;
 713       errlen = build_int_cst (integer_type_node, 0);
 714     }
 715
 716   tmp = build_call_expr_loc (input_location,
 717              gfor_fndecl_caf_register, 6,
 718              fold_build2_loc (input_location,
 719                               MAX_EXPR, size_type_node, size,
 720                               build_int_cst (size_type_node, 1)),
 721              build_int_cst (integer_type_node,
 722                             GFC_CAF_COARRAY_ALLOC),
 723              token, pstat, errmsg, errlen);
 724
 725   tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 726                          TREE_TYPE (pointer), pointer,
 727                          fold_convert ( TREE_TYPE (pointer), tmp));
 728   gfc_add_expr_to_block (block, tmp);
 729 }
 730
 731
 732 /* Generate code for an ALLOCATE statement when the argument is an
 733    allocatable variable.  If the variable is currently allocated, it is an
 734    error to allocate it again.
 735
 736    This function follows the following pseudo-code:
 737
 738     void *
 739     allocate_allocatable (void *mem, size_t size, integer_type stat)
 740     {
 741       if (mem == NULL)
 742         return allocate (size, stat);
 743       else
 744       {
 745         if (stat)
 746           stat = LIBERROR_ALLOCATION;
 747         else
 748           runtime_error ("Attempting to allocate already allocated variable");
 749       }
 750     }
 751
 752     expr must be set to the original expression being allocated for its locus
 753     and variable name in case a runtime error has to be printed.  */
 754 void
 755 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
 756                           tree status, tree errmsg, tree errlen, tree label_finish,
 757                           gfc_expr* expr)
 758 {
 759   stmtblock_t alloc_block;
 760   tree tmp, null_mem, alloc, error;
 761   tree type = TREE_TYPE (mem);
 762
 763   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 764     size = fold_convert (size_type_node, size);
 765
 766   null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
 767                                             boolean_type_node, mem,
 768                                             build_int_cst (type, 0)),
 769                            PRED_FORTRAN_FAIL_ALLOC);
 770
 771   /* If mem is NULL, we call gfc_allocate_using_malloc or
 772      gfc_allocate_using_lib.  */
 773   gfc_start_block (&alloc_block);
 774
 775   if (gfc_option.coarray == GFC_FCOARRAY_LIB
 776       && gfc_expr_attr (expr).codimension)
 777     {
 778       tree cond;
 779
 780       gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
 781                               errmsg, errlen);
 782       if (status != NULL_TREE)
 783         {
 784           TREE_USED (label_finish) = 1;
 785           tmp = build1_v (GOTO_EXPR, label_finish);
 786           cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 787                                   status, build_zero_cst (TREE_TYPE (status)));
 788           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 789                                  gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
 790                                  tmp, build_empty_stmt (input_location));
 791           gfc_add_expr_to_block (&alloc_block, tmp);
 792         }
 793     }
 794   else
 795     gfc_allocate_using_malloc (&alloc_block, mem, size, status);
 796
 797   alloc = gfc_finish_block (&alloc_block);
 798
 799   /* If mem is not NULL, we issue a runtime error or set the
 800      status variable.  */
 801   if (expr)
 802     {
 803       tree varname;
 804
 805       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 806       varname = gfc_build_cstring_const (expr->symtree->name);
 807       varname = gfc_build_addr_expr (pchar_type_node, varname);
 808
 809       error = gfc_trans_runtime_error (true, &expr->where,
 810                                        "Attempting to allocate already"
 811                                        " allocated variable '%s'",
 812                                        varname);
 813     }
 814   else
 815     error = gfc_trans_runtime_error (true, NULL,
 816                                      "Attempting to allocate already allocated"
 817                                      " variable");
 818
 819   if (status != NULL_TREE)
 820     {
 821       tree status_type = TREE_TYPE (status);
 822
 823       error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 824               status, build_int_cst (status_type, LIBERROR_ALLOCATION));
 825     }
 826
 827   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
 828                          error, alloc);
 829   gfc_add_expr_to_block (block, tmp);
 830 }
 831
 832
 833 /* Free a given variable, if it's not NULL.  */
 834 tree
 835 gfc_call_free (tree var)
 836 {
 837   stmtblock_t block;
 838   tree tmp, cond, call;
 839
 840   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 841     var = fold_convert (pvoid_type_node, var);
 842
 843   gfc_start_block (&block);
 844   var = gfc_evaluate_now (var, &block);
 845   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
 846                           build_int_cst (pvoid_type_node, 0));
 847   call = build_call_expr_loc (input_location,
 848                               builtin_decl_explicit (BUILT_IN_FREE),
 849                               1, var);
 850   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
 851                          build_empty_stmt (input_location));
 852   gfc_add_expr_to_block (&block, tmp);
 853
 854   return gfc_finish_block (&block);
 855 }
 856
 857
 858 /* Build a call to a FINAL procedure, which finalizes "var".  */
 859
 860 static tree
 861 gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 862                       bool fini_coarray, gfc_expr *class_size)
 863 {
 864   stmtblock_t block;
 865   gfc_se se;
 866   tree final_fndecl, array, size, tmp;
 867   symbol_attribute attr;
 868
 869   gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
 870   gcc_assert (var);
 871
 872   gfc_start_block (&block);
 873   gfc_init_se (&se, NULL);
 874   gfc_conv_expr (&se, final_wrapper);
 875   final_fndecl = se.expr;
 876   if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
 877     final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
 878
 879   if (ts.type == BT_DERIVED)
 880     {
 881       tree elem_size;
 882
 883       gcc_assert (!class_size);
 884       elem_size = gfc_typenode_for_spec (&ts);
 885       elem_size = TYPE_SIZE_UNIT (elem_size);
 886       size = fold_convert (gfc_array_index_type, elem_size);
 887
 888       gfc_init_se (&se, NULL);
 889       se.want_pointer = 1;
 890       if (var->rank)
 891         {
 892           se.descriptor_only = 1;
 893           gfc_conv_expr_descriptor (&se, var);
 894           array = se.expr;
 895         }
 896       else
 897         {
 898           gfc_conv_expr (&se, var);
 899           gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
 900           array = se.expr;
 901
 902           /* No copy back needed, hence set attr's allocatable/pointer
 903              to zero.  */
 904           gfc_clear_attr (&attr);
 905           gfc_init_se (&se, NULL);
 906           array = gfc_conv_scalar_to_descriptor (&se, array, attr);
 907           gcc_assert (se.post.head == NULL_TREE);
 908         }
 909     }
 910   else
 911     {
 912       gfc_expr *array_expr;
 913       gcc_assert (class_size);
 914       gfc_init_se (&se, NULL);
 915       gfc_conv_expr (&se, class_size);
 916       gfc_add_block_to_block (&block, &se.pre);
 917       gcc_assert (se.post.head == NULL_TREE);
 918       size = se.expr;
 919
 920       array_expr = gfc_copy_expr (var);
 921       gfc_init_se (&se, NULL);
 922       se.want_pointer = 1;
 923       if (array_expr->rank)
 924         {
 925           gfc_add_class_array_ref (array_expr);
 926           se.descriptor_only = 1;
 927           gfc_conv_expr_descriptor (&se, array_expr);
 928           array = se.expr;
 929         }
 930       else
 931         {
 932           gfc_add_data_component (array_expr);
 933           gfc_conv_expr (&se, array_expr);
 934           gfc_add_block_to_block (&block, &se.pre);
 935           gcc_assert (se.post.head == NULL_TREE);
 936           array = se.expr;
 937           if (TREE_CODE (array) == ADDR_EXPR
 938               && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
 939             tmp = TREE_OPERAND (array, 0);
 940
 941           if (!gfc_is_coarray (array_expr))
 942             {
 943               /* No copy back needed, hence set attr's allocatable/pointer
 944                  to zero.  */
 945               gfc_clear_attr (&attr);
 946               gfc_init_se (&se, NULL);
 947               array = gfc_conv_scalar_to_descriptor (&se, array, attr);
 948             }
 949           gcc_assert (se.post.head == NULL_TREE);
 950         }
 951       gfc_free_expr (array_expr);
 952     }
 953
 954   if (!POINTER_TYPE_P (TREE_TYPE (array)))
 955     array = gfc_build_addr_expr (NULL, array);
 956
 957   gfc_add_block_to_block (&block, &se.pre);
 958   tmp = build_call_expr_loc (input_location,
 959                              final_fndecl, 3, array,
 960                              size, fini_coarray ? boolean_true_node
 961                                                 : boolean_false_node);
 962   gfc_add_block_to_block (&block, &se.post);
 963   gfc_add_expr_to_block (&block, tmp);
 964   return gfc_finish_block (&block);
 965 }
 966
 967
 968 bool
 969 gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
 970                              bool fini_coarray)
 971 {
 972   gfc_se se;
 973   stmtblock_t block2;
 974   tree final_fndecl, size, array, tmp, cond;
 975   symbol_attribute attr;
 976   gfc_expr *final_expr = NULL;
 977
 978   if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
 979     return false;
 980
 981   gfc_init_block (&block2);
 982
 983   if (comp->ts.type == BT_DERIVED)
 984     {
 985       if (comp->attr.pointer)
 986         return false;
 987
 988       gfc_is_finalizable (comp->ts.u.derived, &final_expr);
 989       if (!final_expr)
 990         return false;
 991
 992       gfc_init_se (&se, NULL);
 993       gfc_conv_expr (&se, final_expr);
 994       final_fndecl = se.expr;
 995       size = gfc_typenode_for_spec (&comp->ts);
 996       size = TYPE_SIZE_UNIT (size);
 997       size = fold_convert (gfc_array_index_type, size);
 998
 999       array = decl;
1000     }
1001   else /* comp->ts.type == BT_CLASS.  */
1002     {
1003       if (CLASS_DATA (comp)->attr.class_pointer)
1004         return false;
1005
1006       gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1007       final_fndecl = gfc_vtable_final_get (decl);
1008       size = gfc_vtable_size_get (decl);
1009       array = gfc_class_data_get (decl);
1010     }
1011
1012   if (comp->attr.allocatable
1013       || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1014     {
1015       tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1016             ?  gfc_conv_descriptor_data_get (array) : array;
1017       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1018                             tmp, fold_convert (TREE_TYPE (tmp),
1019                                                  null_pointer_node));
1020     }
1021   else
1022     cond = boolean_true_node;
1023
1024   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1025     {
1026       gfc_clear_attr (&attr);
1027       gfc_init_se (&se, NULL);
1028       array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1029       gfc_add_block_to_block (&block2, &se.pre);
1030       gcc_assert (se.post.head == NULL_TREE);
1031     }
1032
1033   if (!POINTER_TYPE_P (TREE_TYPE (array)))
1034     array = gfc_build_addr_expr (NULL, array);
1035
1036   if (!final_expr)
1037     {
1038       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1039                              final_fndecl,
1040                              fold_convert (TREE_TYPE (final_fndecl),
1041                                            null_pointer_node));
1042       cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1043                               boolean_type_node, cond, tmp);
1044     }
1045
1046   if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1047     final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1048
1049   tmp = build_call_expr_loc (input_location,
1050                              final_fndecl, 3, array,
1051                              size, fini_coarray ? boolean_true_node
1052                                                 : boolean_false_node);
1053   gfc_add_expr_to_block (&block2, tmp);
1054   tmp = gfc_finish_block (&block2);
1055
1056   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1057                          build_empty_stmt (input_location));
1058   gfc_add_expr_to_block (block, tmp);
1059
1060   return true;
1061 }
1062
1063
1064 /* Add a call to the finalizer, using the passed *expr. Returns
1065    true when a finalizer call has been inserted.  */
1066
1067 bool
1068 gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
1069 {
1070   tree tmp;
1071   gfc_ref *ref;
1072   gfc_expr *expr;
1073   gfc_expr *final_expr = NULL;
1074   gfc_expr *elem_size = NULL;
1075   bool has_finalizer = false;
1076
1077   if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1078     return false;
1079
1080   if (expr2->ts.type == BT_DERIVED)
1081     {
1082       gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
1083       if (!final_expr)
1084         return false;
1085     }
1086
1087   /* If we have a class array, we need go back to the class
1088      container.  */
1089   expr = gfc_copy_expr (expr2);
1090
1091   if (expr->ref && expr->ref->next && !expr->ref->next->next
1092       && expr->ref->next->type == REF_ARRAY
1093       && expr->ref->type == REF_COMPONENT
1094       && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1095     {
1096       gfc_free_ref_list (expr->ref);
1097       expr->ref = NULL;
1098     }
1099   else
1100     for (ref = expr->ref; ref; ref = ref->next)
1101       if (ref->next && ref->next->next && !ref->next->next->next
1102          && ref->next->next->type == REF_ARRAY
1103          && ref->next->type == REF_COMPONENT
1104          && strcmp (ref->next->u.c.component->name, "_data") == 0)
1105        {
1106          gfc_free_ref_list (ref->next);
1107          ref->next = NULL;
1108        }
1109
1110   if (expr->ts.type == BT_CLASS)
1111     {
1112       has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
1113
1114       if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
1115         expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1116
1117       final_expr = gfc_copy_expr (expr);
1118       gfc_add_vptr_component (final_expr);
1119       gfc_add_component_ref (final_expr, "_final");
1120
1121       elem_size = gfc_copy_expr (expr);
1122       gfc_add_vptr_component (elem_size);
1123       gfc_add_component_ref (elem_size, "_size");
1124     }
1125
1126   gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
1127
1128   tmp = gfc_build_final_call (expr->ts, final_expr, expr,
1129                               false, elem_size);
1130
1131   if (expr->ts.type == BT_CLASS && !has_finalizer)
1132     {
1133       tree cond;
1134       gfc_se se;
1135
1136       gfc_init_se (&se, NULL);
1137       se.want_pointer = 1;
1138       gfc_conv_expr (&se, final_expr);
1139       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1140                               se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
1141
1142       /* For CLASS(*) not only sym->_vtab->_final can be NULL
1143          but already sym->_vtab itself.  */
1144       if (UNLIMITED_POLY (expr))
1145         {
1146           tree cond2;
1147           gfc_expr *vptr_expr;
1148
1149           vptr_expr = gfc_copy_expr (expr);
1150           gfc_add_vptr_component (vptr_expr);
1151
1152           gfc_init_se (&se, NULL);
1153           se.want_pointer = 1;
1154           gfc_conv_expr (&se, vptr_expr);
1155           gfc_free_expr (vptr_expr);
1156
1157           cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1158                                    se.expr,
1159                                    build_int_cst (TREE_TYPE (se.expr), 0));
1160           cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1161                                   boolean_type_node, cond2, cond);
1162         }
1163
1164       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1165                              cond, tmp, build_empty_stmt (input_location));
1166     }
1167
1168   gfc_add_expr_to_block (block, tmp);
1169
1170   return true;
1171 }
1172
1173
1174 /* User-deallocate; we emit the code directly from the front-end, and the
1175    logic is the same as the previous library function:
1176
1177     void
1178     deallocate (void *pointer, GFC_INTEGER_4 * stat)
1179     {
1180       if (!pointer)
1181         {
1182           if (stat)
1183             *stat = 1;
1184           else
1185             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1186         }
1187       else
1188         {
1189           free (pointer);
1190           if (stat)
1191             *stat = 0;
1192         }
1193     }
1194
1195    In this front-end version, status doesn't have to be GFC_INTEGER_4.
1196    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1197    even when no status variable is passed to us (this is used for
1198    unconditional deallocation generated by the front-end at end of
1199    each procedure).
1200
1201    If a runtime-message is possible, `expr' must point to the original
1202    expression being deallocated for its locus and variable name.
1203
1204    For coarrays, "pointer" must be the array descriptor and not its
1205    "data" component.  */
1206 tree
1207 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1208                             tree errlen, tree label_finish,
1209                             bool can_fail, gfc_expr* expr, bool coarray)
1210 {
1211   stmtblock_t null, non_null;
1212   tree cond, tmp, error;
1213   tree status_type = NULL_TREE;
1214   tree caf_decl = NULL_TREE;
1215
1216   if (coarray)
1217     {
1218       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
1219       caf_decl = pointer;
1220       pointer = gfc_conv_descriptor_data_get (caf_decl);
1221       STRIP_NOPS (pointer);
1222     }
1223
1224   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1225                           build_int_cst (TREE_TYPE (pointer), 0));
1226
1227   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1228      we emit a runtime error.  */
1229   gfc_start_block (&null);
1230   if (!can_fail)
1231     {
1232       tree varname;
1233
1234       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1235
1236       varname = gfc_build_cstring_const (expr->symtree->name);
1237       varname = gfc_build_addr_expr (pchar_type_node, varname);
1238
1239       error = gfc_trans_runtime_error (true, &expr->where,
1240                                        "Attempt to DEALLOCATE unallocated '%s'",
1241                                        varname);
1242     }
1243   else
1244     error = build_empty_stmt (input_location);
1245
1246   if (status != NULL_TREE && !integer_zerop (status))
1247     {
1248       tree cond2;
1249
1250       status_type = TREE_TYPE (TREE_TYPE (status));
1251       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1252                                status, build_int_cst (TREE_TYPE (status), 0));
1253       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1254                              fold_build1_loc (input_location, INDIRECT_REF,
1255                                               status_type, status),
1256                              build_int_cst (status_type, 1));
1257       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1258                                cond2, tmp, error);
1259     }
1260
1261   gfc_add_expr_to_block (&null, error);
1262
1263   /* When POINTER is not NULL, we free it.  */
1264   gfc_start_block (&non_null);
1265   gfc_add_finalizer_call (&non_null, expr);
1266   if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
1267     {
1268       tmp = build_call_expr_loc (input_location,
1269                                  builtin_decl_explicit (BUILT_IN_FREE), 1,
1270                                  fold_convert (pvoid_type_node, pointer));
1271       gfc_add_expr_to_block (&non_null, tmp);
1272
1273       if (status != NULL_TREE && !integer_zerop (status))
1274         {
1275           /* We set STATUS to zero if it is present.  */
1276           tree status_type = TREE_TYPE (TREE_TYPE (status));
1277           tree cond2;
1278
1279           cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1280                                    status,
1281                                    build_int_cst (TREE_TYPE (status), 0));
1282           tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1283                                  fold_build1_loc (input_location, INDIRECT_REF,
1284                                                   status_type, status),
1285                                  build_int_cst (status_type, 0));
1286           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1287                                  gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1288                                  tmp, build_empty_stmt (input_location));
1289           gfc_add_expr_to_block (&non_null, tmp);
1290         }
1291     }
1292   else
1293     {
1294       tree caf_type, token, cond2;
1295       tree pstat = null_pointer_node;
1296
1297       if (errmsg == NULL_TREE)
1298         {
1299           gcc_assert (errlen == NULL_TREE);
1300           errmsg = null_pointer_node;
1301           errlen = build_zero_cst (integer_type_node);
1302         }
1303       else
1304         {
1305           gcc_assert (errlen != NULL_TREE);
1306           if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1307             errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1308         }
1309
1310       caf_type = TREE_TYPE (caf_decl);
1311
1312       if (status != NULL_TREE && !integer_zerop (status))
1313         {
1314           gcc_assert (status_type == integer_type_node);
1315           pstat = status;
1316         }
1317
1318       if (GFC_DESCRIPTOR_TYPE_P (caf_type)
1319           && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
1320         token = gfc_conv_descriptor_token (caf_decl);
1321       else if (DECL_LANG_SPECIFIC (caf_decl)
1322                && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1323         token = GFC_DECL_TOKEN (caf_decl);
1324       else
1325         {
1326           gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1327                       && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
1328           token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1329         }
1330
1331       token = gfc_build_addr_expr  (NULL_TREE, token);
1332       tmp = build_call_expr_loc (input_location,
1333              gfor_fndecl_caf_deregister, 4,
1334              token, pstat, errmsg, errlen);
1335       gfc_add_expr_to_block (&non_null, tmp);
1336
1337       if (status != NULL_TREE)
1338         {
1339           tree stat = build_fold_indirect_ref_loc (input_location, status);
1340
1341           TREE_USED (label_finish) = 1;
1342           tmp = build1_v (GOTO_EXPR, label_finish);
1343           cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1344                                    stat, build_zero_cst (TREE_TYPE (stat)));
1345           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1346                                  gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1347                                  tmp, build_empty_stmt (input_location));
1348           gfc_add_expr_to_block (&non_null, tmp);
1349         }
1350     }
1351
1352   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1353                           gfc_finish_block (&null),
1354                           gfc_finish_block (&non_null));
1355 }
1356
1357
1358 /* Generate code for deallocation of allocatable scalars (variables or
1359    components). Before the object itself is freed, any allocatable
1360    subcomponents are being deallocated.  */
1361
1362 tree
1363 gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
1364                                    gfc_expr* expr, gfc_typespec ts)
1365 {
1366   stmtblock_t null, non_null;
1367   tree cond, tmp, error;
1368   bool finalizable;
1369
1370   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1371                           build_int_cst (TREE_TYPE (pointer), 0));
1372
1373   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1374      we emit a runtime error.  */
1375   gfc_start_block (&null);
1376   if (!can_fail)
1377     {
1378       tree varname;
1379
1380       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1381
1382       varname = gfc_build_cstring_const (expr->symtree->name);
1383       varname = gfc_build_addr_expr (pchar_type_node, varname);
1384
1385       error = gfc_trans_runtime_error (true, &expr->where,
1386                                        "Attempt to DEALLOCATE unallocated '%s'",
1387                                        varname);
1388     }
1389   else
1390     error = build_empty_stmt (input_location);
1391
1392   if (status != NULL_TREE && !integer_zerop (status))
1393     {
1394       tree status_type = TREE_TYPE (TREE_TYPE (status));
1395       tree cond2;
1396
1397       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1398                                status, build_int_cst (TREE_TYPE (status), 0));
1399       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1400                              fold_build1_loc (input_location, INDIRECT_REF,
1401                                               status_type, status),
1402                              build_int_cst (status_type, 1));
1403       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1404                                cond2, tmp, error);
1405     }
1406
1407   gfc_add_expr_to_block (&null, error);
1408
1409   /* When POINTER is not NULL, we free it.  */
1410   gfc_start_block (&non_null);
1411
1412   /* Free allocatable components.  */
1413   finalizable = gfc_add_finalizer_call (&non_null, expr);
1414   if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1415     {
1416       tmp = build_fold_indirect_ref_loc (input_location, pointer);
1417       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
1418       gfc_add_expr_to_block (&non_null, tmp);
1419     }
1420
1421   tmp = build_call_expr_loc (input_location,
1422                              builtin_decl_explicit (BUILT_IN_FREE), 1,
1423                              fold_convert (pvoid_type_node, pointer));
1424   gfc_add_expr_to_block (&non_null, tmp);
1425
1426   if (status != NULL_TREE && !integer_zerop (status))
1427     {
1428       /* We set STATUS to zero if it is present.  */
1429       tree status_type = TREE_TYPE (TREE_TYPE (status));
1430       tree cond2;
1431
1432       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1433                                status, build_int_cst (TREE_TYPE (status), 0));
1434       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1435                              fold_build1_loc (input_location, INDIRECT_REF,
1436                                               status_type, status),
1437                              build_int_cst (status_type, 0));
1438       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
1439                              tmp, build_empty_stmt (input_location));
1440       gfc_add_expr_to_block (&non_null, tmp);
1441     }
1442
1443   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1444                           gfc_finish_block (&null),
1445                           gfc_finish_block (&non_null));
1446 }
1447
1448
1449 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
1450    following pseudo-code:
1451
1452 void *
1453 internal_realloc (void *mem, size_t size)
1454 {
1455   res = realloc (mem, size);
1456   if (!res && size != 0)
1457     _gfortran_os_error ("Allocation would exceed memory limit");
1458
1459   return res;
1460 }  */
1461 tree
1462 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1463 {
1464   tree msg, res, nonzero, null_result, tmp;
1465   tree type = TREE_TYPE (mem);
1466
1467   size = gfc_evaluate_now (size, block);
1468
1469   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
1470     size = fold_convert (size_type_node, size);
1471
1472   /* Create a variable to hold the result.  */
1473   res = gfc_create_var (type, NULL);
1474
1475   /* Call realloc and check the result.  */
1476   tmp = build_call_expr_loc (input_location,
1477                          builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1478                          fold_convert (pvoid_type_node, mem), size);
1479   gfc_add_modify (block, res, fold_convert (type, tmp));
1480   null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1481                                  res, build_int_cst (pvoid_type_node, 0));
1482   nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1483                              build_int_cst (size_type_node, 0));
1484   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1485                                  null_result, nonzero);
1486   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1487                              ("Allocation would exceed memory limit"));
1488   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1489                          null_result,
1490                          build_call_expr_loc (input_location,
1491                                               gfor_fndecl_os_error, 1, msg),
1492                          build_empty_stmt (input_location));
1493   gfc_add_expr_to_block (block, tmp);
1494
1495   return res;
1496 }
1497
1498
1499 /* Add an expression to another one, either at the front or the back.  */
1500
1501 static void
1502 add_expr_to_chain (tree* chain, tree expr, bool front)
1503 {
1504   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1505     return;
1506
1507   if (*chain)
1508     {
1509       if (TREE_CODE (*chain) != STATEMENT_LIST)
1510         {
1511           tree tmp;
1512
1513           tmp = *chain;
1514           *chain = NULL_TREE;
1515           append_to_statement_list (tmp, chain);
1516         }
1517
1518       if (front)
1519         {
1520           tree_stmt_iterator i;
1521
1522           i = tsi_start (*chain);
1523           tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1524         }
1525       else
1526         append_to_statement_list (expr, chain);
1527     }
1528   else
1529     *chain = expr;
1530 }
1531
1532
1533 /* Add a statement at the end of a block.  */
1534
1535 void
1536 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1537 {
1538   gcc_assert (block);
1539   add_expr_to_chain (&block->head, expr, false);
1540 }
1541
1542
1543 /* Add a statement at the beginning of a block.  */
1544
1545 void
1546 gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
1547 {
1548   gcc_assert (block);
1549   add_expr_to_chain (&block->head, expr, true);
1550 }
1551
1552
1553 /* Add a block the end of a block.  */
1554
1555 void
1556 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1557 {
1558   gcc_assert (append);
1559   gcc_assert (!append->has_scope);
1560
1561   gfc_add_expr_to_block (block, append->head);
1562   append->head = NULL_TREE;
1563 }
1564
1565
1566 /* Save the current locus.  The structure may not be complete, and should
1567    only be used with gfc_restore_backend_locus.  */
1568
1569 void
1570 gfc_save_backend_locus (locus * loc)
1571 {
1572   loc->lb = XCNEW (gfc_linebuf);
1573   loc->lb->location = input_location;
1574   loc->lb->file = gfc_current_backend_file;
1575 }
1576
1577
1578 /* Set the current locus.  */
1579
1580 void
1581 gfc_set_backend_locus (locus * loc)
1582 {
1583   gfc_current_backend_file = loc->lb->file;
1584   input_location = loc->lb->location;
1585 }
1586
1587
1588 /* Restore the saved locus. Only used in conjunction with
1589    gfc_save_backend_locus, to free the memory when we are done.  */
1590
1591 void
1592 gfc_restore_backend_locus (locus * loc)
1593 {
1594   gfc_set_backend_locus (loc);
1595   free (loc->lb);
1596 }
1597
1598
1599 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1600    This static function is wrapped by gfc_trans_code_cond and
1601    gfc_trans_code.  */
1602
1603 static tree
1604 trans_code (gfc_code * code, tree cond)
1605 {
1606   stmtblock_t block;
1607   tree res;
1608
1609   if (!code)
1610     return build_empty_stmt (input_location);
1611
1612   gfc_start_block (&block);
1613
1614   /* Translate statements one by one into GENERIC trees until we reach
1615      the end of this gfc_code branch.  */
1616   for (; code; code = code->next)
1617     {
1618       if (code->here != 0)
1619         {
1620           res = gfc_trans_label_here (code);
1621           gfc_add_expr_to_block (&block, res);
1622         }
1623
1624       gfc_set_backend_locus (&code->loc);
1625
1626       switch (code->op)
1627         {
1628         case EXEC_NOP:
1629         case EXEC_END_BLOCK:
1630         case EXEC_END_NESTED_BLOCK:
1631         case EXEC_END_PROCEDURE:
1632           res = NULL_TREE;
1633           break;
1634
1635         case EXEC_ASSIGN:
1636           if (code->expr1->ts.type == BT_CLASS)
1637             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1638           else
1639             res = gfc_trans_assign (code);
1640           break;
1641
1642         case EXEC_LABEL_ASSIGN:
1643           res = gfc_trans_label_assign (code);
1644           break;
1645
1646         case EXEC_POINTER_ASSIGN:
1647           if (code->expr1->ts.type == BT_CLASS)
1648             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1649           else if (UNLIMITED_POLY (code->expr2)
1650                    && code->expr1->ts.type == BT_DERIVED
1651                    && (code->expr1->ts.u.derived->attr.sequence
1652                        || code->expr1->ts.u.derived->attr.is_bind_c))
1653             /* F2003: C717  */
1654             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1655           else
1656             res = gfc_trans_pointer_assign (code);
1657           break;
1658
1659         case EXEC_INIT_ASSIGN:
1660           if (code->expr1->ts.type == BT_CLASS)
1661             res = gfc_trans_class_init_assign (code);
1662           else
1663             res = gfc_trans_init_assign (code);
1664           break;
1665
1666         case EXEC_CONTINUE:
1667           res = NULL_TREE;
1668           break;
1669
1670         case EXEC_CRITICAL:
1671           res = gfc_trans_critical (code);
1672           break;
1673
1674         case EXEC_CYCLE:
1675           res = gfc_trans_cycle (code);
1676           break;
1677
1678         case EXEC_EXIT:
1679           res = gfc_trans_exit (code);
1680           break;
1681
1682         case EXEC_GOTO:
1683           res = gfc_trans_goto (code);
1684           break;
1685
1686         case EXEC_ENTRY:
1687           res = gfc_trans_entry (code);
1688           break;
1689
1690         case EXEC_PAUSE:
1691           res = gfc_trans_pause (code);
1692           break;
1693
1694         case EXEC_STOP:
1695         case EXEC_ERROR_STOP:
1696           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1697           break;
1698
1699         case EXEC_CALL:
1700           /* For MVBITS we've got the special exception that we need a
1701              dependency check, too.  */
1702           {
1703             bool is_mvbits = false;
1704
1705             if (code->resolved_isym)
1706               {
1707                 res = gfc_conv_intrinsic_subroutine (code);
1708                 if (res != NULL_TREE)
1709                   break;
1710               }
1711
1712             if (code->resolved_isym
1713                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1714               is_mvbits = true;
1715
1716             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1717                                   NULL_TREE, false);
1718           }
1719           break;
1720
1721         case EXEC_CALL_PPC:
1722           res = gfc_trans_call (code, false, NULL_TREE,
1723                                 NULL_TREE, false);
1724           break;
1725
1726         case EXEC_ASSIGN_CALL:
1727           res = gfc_trans_call (code, true, NULL_TREE,
1728                                 NULL_TREE, false);
1729           break;
1730
1731         case EXEC_RETURN:
1732           res = gfc_trans_return (code);
1733           break;
1734
1735         case EXEC_IF:
1736           res = gfc_trans_if (code);
1737           break;
1738
1739         case EXEC_ARITHMETIC_IF:
1740           res = gfc_trans_arithmetic_if (code);
1741           break;
1742
1743         case EXEC_BLOCK:
1744           res = gfc_trans_block_construct (code);
1745           break;
1746
1747         case EXEC_DO:
1748           res = gfc_trans_do (code, cond);
1749           break;
1750
1751         case EXEC_DO_CONCURRENT:
1752           res = gfc_trans_do_concurrent (code);
1753           break;
1754
1755         case EXEC_DO_WHILE:
1756           res = gfc_trans_do_while (code);
1757           break;
1758
1759         case EXEC_SELECT:
1760           res = gfc_trans_select (code);
1761           break;
1762
1763         case EXEC_SELECT_TYPE:
1764           /* Do nothing. SELECT TYPE statements should be transformed into
1765           an ordinary SELECT CASE at resolution stage.
1766           TODO: Add an error message here once this is done.  */
1767           res = NULL_TREE;
1768           break;
1769
1770         case EXEC_FLUSH:
1771           res = gfc_trans_flush (code);
1772           break;
1773
1774         case EXEC_SYNC_ALL:
1775         case EXEC_SYNC_IMAGES:
1776         case EXEC_SYNC_MEMORY:
1777           res = gfc_trans_sync (code, code->op);
1778           break;
1779
1780         case EXEC_LOCK:
1781         case EXEC_UNLOCK:
1782           res = gfc_trans_lock_unlock (code, code->op);
1783           break;
1784
1785         case EXEC_FORALL:
1786           res = gfc_trans_forall (code);
1787           break;
1788
1789         case EXEC_WHERE:
1790           res = gfc_trans_where (code);
1791           break;
1792
1793         case EXEC_ALLOCATE:
1794           res = gfc_trans_allocate (code);
1795           break;
1796
1797         case EXEC_DEALLOCATE:
1798           res = gfc_trans_deallocate (code);
1799           break;
1800
1801         case EXEC_OPEN:
1802           res = gfc_trans_open (code);
1803           break;
1804
1805         case EXEC_CLOSE:
1806           res = gfc_trans_close (code);
1807           break;
1808
1809         case EXEC_READ:
1810           res = gfc_trans_read (code);
1811           break;
1812
1813         case EXEC_WRITE:
1814           res = gfc_trans_write (code);
1815           break;
1816
1817         case EXEC_IOLENGTH:
1818           res = gfc_trans_iolength (code);
1819           break;
1820
1821         case EXEC_BACKSPACE:
1822           res = gfc_trans_backspace (code);
1823           break;
1824
1825         case EXEC_ENDFILE:
1826           res = gfc_trans_endfile (code);
1827           break;
1828
1829         case EXEC_INQUIRE:
1830           res = gfc_trans_inquire (code);
1831           break;
1832
1833         case EXEC_WAIT:
1834           res = gfc_trans_wait (code);
1835           break;
1836
1837         case EXEC_REWIND:
1838           res = gfc_trans_rewind (code);
1839           break;
1840
1841         case EXEC_TRANSFER:
1842           res = gfc_trans_transfer (code);
1843           break;
1844
1845         case EXEC_DT_END:
1846           res = gfc_trans_dt_end (code);
1847           break;
1848
1849         case EXEC_OMP_ATOMIC:
1850         case EXEC_OMP_BARRIER:
1851         case EXEC_OMP_CANCEL:
1852         case EXEC_OMP_CANCELLATION_POINT:
1853         case EXEC_OMP_CRITICAL:
1854         case EXEC_OMP_DISTRIBUTE:
1855         case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1856         case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1857         case EXEC_OMP_DISTRIBUTE_SIMD:
1858         case EXEC_OMP_DO:
1859         case EXEC_OMP_DO_SIMD:
1860         case EXEC_OMP_FLUSH:
1861         case EXEC_OMP_MASTER:
1862         case EXEC_OMP_ORDERED:
1863         case EXEC_OMP_PARALLEL:
1864         case EXEC_OMP_PARALLEL_DO:
1865         case EXEC_OMP_PARALLEL_DO_SIMD:
1866         case EXEC_OMP_PARALLEL_SECTIONS:
1867         case EXEC_OMP_PARALLEL_WORKSHARE:
1868         case EXEC_OMP_SECTIONS:
1869         case EXEC_OMP_SIMD:
1870         case EXEC_OMP_SINGLE:
1871         case EXEC_OMP_TARGET:
1872         case EXEC_OMP_TARGET_DATA:
1873         case EXEC_OMP_TARGET_TEAMS:
1874         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1875         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1876         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1877         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1878         case EXEC_OMP_TARGET_UPDATE:
1879         case EXEC_OMP_TASK:
1880         case EXEC_OMP_TASKGROUP:
1881         case EXEC_OMP_TASKWAIT:
1882         case EXEC_OMP_TASKYIELD:
1883         case EXEC_OMP_TEAMS:
1884         case EXEC_OMP_TEAMS_DISTRIBUTE:
1885         case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1886         case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1887         case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
1888         case EXEC_OMP_WORKSHARE:
1889           res = gfc_trans_omp_directive (code);
1890           break;
1891
1892         default:
1893           internal_error ("gfc_trans_code(): Bad statement code");
1894         }
1895
1896       gfc_set_backend_locus (&code->loc);
1897
1898       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1899         {
1900           if (TREE_CODE (res) != STATEMENT_LIST)
1901             SET_EXPR_LOCATION (res, input_location);
1902
1903           /* Add the new statement to the block.  */
1904           gfc_add_expr_to_block (&block, res);
1905         }
1906     }
1907
1908   /* Return the finished block.  */
1909   return gfc_finish_block (&block);
1910 }
1911
1912
1913 /* Translate an executable statement with condition, cond.  The condition is
1914    used by gfc_trans_do to test for IO result conditions inside implied
1915    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1916
1917 tree
1918 gfc_trans_code_cond (gfc_code * code, tree cond)
1919 {
1920   return trans_code (code, cond);
1921 }
1922
1923 /* Translate an executable statement without condition.  */
1924
1925 tree
1926 gfc_trans_code (gfc_code * code)
1927 {
1928   return trans_code (code, NULL_TREE);
1929 }
1930
1931
1932 /* This function is called after a complete program unit has been parsed
1933    and resolved.  */
1934
1935 void
1936 gfc_generate_code (gfc_namespace * ns)
1937 {
1938   ompws_flags = 0;
1939   if (ns->is_block_data)
1940     {
1941       gfc_generate_block_data (ns);
1942       return;
1943     }
1944
1945   gfc_generate_function_code (ns);
1946 }
1947
1948
1949 /* This function is called after a complete module has been parsed
1950    and resolved.  */
1951
1952 void
1953 gfc_generate_module_code (gfc_namespace * ns)
1954 {
1955   gfc_namespace *n;
1956   struct module_htab_entry *entry;
1957
1958   gcc_assert (ns->proc_name->backend_decl == NULL);
1959   ns->proc_name->backend_decl
1960     = build_decl (ns->proc_name->declared_at.lb->location,
1961                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1962                   void_type_node);
1963   entry = gfc_find_module (ns->proc_name->name);
1964   if (entry->namespace_decl)
1965     /* Buggy sourcecode, using a module before defining it?  */
1966     entry->decls->empty ();
1967   entry->namespace_decl = ns->proc_name->backend_decl;
1968
1969   gfc_generate_module_vars (ns);
1970
1971   /* We need to generate all module function prototypes first, to allow
1972      sibling calls.  */
1973   for (n = ns->contained; n; n = n->sibling)
1974     {
1975       gfc_entry_list *el;
1976
1977       if (!n->proc_name)
1978         continue;
1979
1980       gfc_create_function_decl (n, false);
1981       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1982       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1983       for (el = ns->entries; el; el = el->next)
1984         {
1985           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1986           gfc_module_add_decl (entry, el->sym->backend_decl);
1987         }
1988     }
1989
1990   for (n = ns->contained; n; n = n->sibling)
1991     {
1992       if (!n->proc_name)
1993         continue;
1994
1995       gfc_generate_function_code (n);
1996     }
1997 }
1998
1999
2000 /* Initialize an init/cleanup block with existing code.  */
2001
2002 void
2003 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2004 {
2005   gcc_assert (block);
2006
2007   block->init = NULL_TREE;
2008   block->code = code;
2009   block->cleanup = NULL_TREE;
2010 }
2011
2012
2013 /* Add a new pair of initializers/clean-up code.  */
2014
2015 void
2016 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2017 {
2018   gcc_assert (block);
2019
2020   /* The new pair of init/cleanup should be "wrapped around" the existing
2021      block of code, thus the initialization is added to the front and the
2022      cleanup to the back.  */
2023   add_expr_to_chain (&block->init, init, true);
2024   add_expr_to_chain (&block->cleanup, cleanup, false);
2025 }
2026
2027
2028 /* Finish up a wrapped block by building a corresponding try-finally expr.  */
2029
2030 tree
2031 gfc_finish_wrapped_block (gfc_wrapped_block* block)
2032 {
2033   tree result;
2034
2035   gcc_assert (block);
2036
2037   /* Build the final expression.  For this, just add init and body together,
2038      and put clean-up with that into a TRY_FINALLY_EXPR.  */
2039   result = block->init;
2040   add_expr_to_chain (&result, block->code, false);
2041   if (block->cleanup)
2042     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2043                          result, block->cleanup);
2044
2045   /* Clear the block.  */
2046   block->init = NULL_TREE;
2047   block->code = NULL_TREE;
2048   block->cleanup = NULL_TREE;
2049
2050   return result;
2051 }
2052
2053
2054 /* Helper function for marking a boolean expression tree as unlikely.  */
2055
2056 tree
2057 gfc_unlikely (tree cond, enum br_predictor predictor)
2058 {
2059   tree tmp;
2060
2061   if (optimize)
2062     {
2063       cond = fold_convert (long_integer_type_node, cond);
2064       tmp = build_zero_cst (long_integer_type_node);
2065       cond = build_call_expr_loc (input_location,
2066                                   builtin_decl_explicit (BUILT_IN_EXPECT),
2067                                   3, cond, tmp,
2068                                   build_int_cst (integer_type_node,
2069                                                  predictor));
2070     }
2071   cond = fold_convert (boolean_type_node, cond);
2072   return cond;
2073 }
2074
2075
2076 /* Helper function for marking a boolean expression tree as likely.  */
2077
2078 tree
2079 gfc_likely (tree cond, enum br_predictor predictor)
2080 {
2081   tree tmp;
2082
2083   if (optimize)
2084     {
2085       cond = fold_convert (long_integer_type_node, cond);
2086       tmp = build_one_cst (long_integer_type_node);
2087       cond = build_call_expr_loc (input_location,
2088                                   builtin_decl_explicit (BUILT_IN_EXPECT),
2089                                   3, cond, tmp,
2090                                   build_int_cst (integer_type_node,
2091                                                  predictor));
2092     }
2093   cond = fold_convert (boolean_type_node, cond);
2094   return cond;
2095 }
2096
2097
2098 /* Get the string length for a deferred character length component.  */
2099
2100 bool
2101 gfc_deferred_strlen (gfc_component *c, tree *decl)
2102 {
2103   char name[GFC_MAX_SYMBOL_LEN+9];
2104   gfc_component *strlen;
2105   if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
2106     return false;
2107   sprintf (name, "_%s_length", c->name);
2108   for (strlen = c; strlen; strlen = strlen->next)
2109     if (strcmp (strlen->name, name) == 0)
2110       break;
2111   *decl = strlen ? strlen->backend_decl : NULL_TREE;
2112   return strlen != NULL;
2113 }