gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
   3    Foundation, Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tree.h"
  26 #include "tree-gimple.h"
  27 #include "ggc.h"
  28 #include "toplev.h"
  29 #include "defaults.h"
  30 #include "real.h"
  31 #include "flags.h"
  32 #include "gfortran.h"
  33 #include "trans.h"
  34 #include "trans-stmt.h"
  35 #include "trans-array.h"
  36 #include "trans-types.h"
  37 #include "trans-const.h"
  38
  39 /* Naming convention for backend interface code:
  40
  41    gfc_trans_*  translate gfc_code into STMT trees.
  42
  43    gfc_conv_*   expression conversion
  44
  45    gfc_get_*    get a backend tree representation of a decl or type  */
  46
  47 static gfc_file *gfc_current_backend_file;
  48
  49 char gfc_msg_bounds[] = N_("Array bound mismatch");
  50 char gfc_msg_fault[] = N_("Array reference out of bounds");
  51 char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  52
  53
  54 /* Advance along TREE_CHAIN n times.  */
  55
  56 tree
  57 gfc_advance_chain (tree t, int n)
  58 {
  59   for (; n > 0; n--)
  60     {
  61       gcc_assert (t != NULL_TREE);
  62       t = TREE_CHAIN (t);
  63     }
  64   return t;
  65 }
  66
  67
  68 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  69
  70 tree
  71 gfc_chainon_list (tree list, tree add)
  72 {
  73   tree l;
  74
  75   l = tree_cons (NULL_TREE, add, NULL_TREE);
  76
  77   return chainon (list, l);
  78 }
  79
  80
  81 /* Strip off a legitimate source ending from the input
  82    string NAME of length LEN.  */
  83
  84 static inline void
  85 remove_suffix (char *name, int len)
  86 {
  87   int i;
  88
  89   for (i = 2; i < 8 && len > i; i++)
  90     {
  91       if (name[len - i] == '.')
  92         {
  93           name[len - i] = '\0';
  94           break;
  95         }
  96     }
  97 }
  98
  99
 100 /* Creates a variable declaration with a given TYPE.  */
 101
 102 tree
 103 gfc_create_var_np (tree type, const char *prefix)
 104 {
 105   tree t;
 106
 107   t = create_tmp_var_raw (type, prefix);
 108
 109   /* No warnings for anonymous variables.  */
 110   if (prefix == NULL)
 111     TREE_NO_WARNING (t) = 1;
 112
 113   return t;
 114 }
 115
 116
 117 /* Like above, but also adds it to the current scope.  */
 118
 119 tree
 120 gfc_create_var (tree type, const char *prefix)
 121 {
 122   tree tmp;
 123
 124   tmp = gfc_create_var_np (type, prefix);
 125
 126   pushdecl (tmp);
 127
 128   return tmp;
 129 }
 130
 131
 132 /* If the an expression is not constant, evaluate it now.  We assign the
 133    result of the expression to an artificially created variable VAR, and
 134    return a pointer to the VAR_DECL node for this variable.  */
 135
 136 tree
 137 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 138 {
 139   tree var;
 140
 141   if (CONSTANT_CLASS_P (expr))
 142     return expr;
 143
 144   var = gfc_create_var (TREE_TYPE (expr), NULL);
 145   gfc_add_modify_expr (pblock, var, expr);
 146
 147   return var;
 148 }
 149
 150
 151 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
 152    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
 153    LHS <- RHS.  */
 154
 155 void
 156 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
 157                 bool tuples_p)
 158 {
 159   tree tmp;
 160
 161 #ifdef ENABLE_CHECKING
 162   /* Make sure that the types of the rhs and the lhs are the same
 163      for scalar assignments.  We should probably have something
 164      similar for aggregates, but right now removing that check just
 165      breaks everything.  */
 166   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
 167               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 168 #endif
 169
 170   tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
 171                      void_type_node, lhs, rhs);
 172   gfc_add_expr_to_block (pblock, tmp);
 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 (0);
 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, 0);
 218
 219   /* Add them to the parent scope.  */
 220   while (decl != NULL_TREE)
 221     {
 222       next = TREE_CHAIN (decl);
 223       TREE_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 ();
 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, 0);
 253           expr = build3_v (BIND_EXPR, decl, expr, block);
 254         }
 255       else
 256         poplevel (0, 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 = build4 (ARRAY_REF, TREE_TYPE (type), t, min_val,
 282                   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       if (DECL_P (t))
 298         TREE_ADDRESSABLE (t) = 1;
 299       t = build1 (ADDR_EXPR, natural_type, t);
 300     }
 301
 302   if (type && natural_type != type)
 303     t = convert (type, t);
 304
 305   return t;
 306 }
 307
 308
 309 /* Build an ARRAY_REF with its natural type.  */
 310
 311 tree
 312 gfc_build_array_ref (tree base, tree offset)
 313 {
 314   tree type = TREE_TYPE (base);
 315   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 316   type = TREE_TYPE (type);
 317
 318   if (DECL_P (base))
 319     TREE_ADDRESSABLE (base) = 1;
 320
 321   /* Strip NON_LVALUE_EXPR nodes.  */
 322   STRIP_TYPE_NOPS (offset);
 323
 324   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 325 }
 326
 327
 328 /* Generate a runtime error if COND is true.  */
 329
 330 void
 331 gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
 332                          const char * msgid, ...)
 333 {
 334   va_list ap;
 335   stmtblock_t block;
 336   tree body;
 337   tree tmp;
 338   tree arg, arg2;
 339   tree *argarray;
 340   tree fntype;
 341   char *message;
 342   const char *p;
 343   int line, nargs, i;
 344
 345   if (integer_zerop (cond))
 346     return;
 347
 348   /* Compute the number of extra arguments from the format string.  */
 349   for (p = msgid, nargs = 0; *p; p++)
 350     if (*p == '%')
 351       {
 352         p++;
 353         if (*p != '%')
 354           nargs++;
 355       }
 356
 357   /* The code to generate the error.  */
 358   gfc_start_block (&block);
 359
 360   if (where)
 361     {
 362 #ifdef USE_MAPPED_LOCATION
 363       line = LOCATION_LINE (where->lb->location);
 364 #else
 365       line = where->lb->linenum;
 366 #endif
 367       asprintf (&message, "At line %d of file %s",  line,
 368                 where->lb->file->filename);
 369     }
 370   else
 371     asprintf (&message, "In file '%s', around line %d",
 372               gfc_source_file, input_line + 1);
 373
 374   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 375   gfc_free(message);
 376
 377   asprintf (&message, "%s", _(msgid));
 378   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 379   gfc_free(message);
 380
 381   /* Build the argument array.  */
 382   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
 383   argarray[0] = arg;
 384   argarray[1] = arg2;
 385   va_start (ap, msgid);
 386   for (i = 0; i < nargs; i++)
 387     argarray[2+i] = va_arg (ap, tree);
 388   va_end (ap);
 389
 390   /* Build the function call to runtime_error_at; because of the variable
 391      number of arguments, we can't use build_call_expr directly.  */
 392   fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 393   tmp = fold_builtin_call_array (TREE_TYPE (fntype),
 394                                  build1 (ADDR_EXPR,
 395                                          build_pointer_type (fntype),
 396                                          gfor_fndecl_runtime_error_at),
 397                                  nargs + 2, argarray);
 398   gfc_add_expr_to_block (&block, tmp);
 399
 400   body = gfc_finish_block (&block);
 401
 402   if (integer_onep (cond))
 403     {
 404       gfc_add_expr_to_block (pblock, body);
 405     }
 406   else
 407     {
 408       /* Tell the compiler that this isn't likely.  */
 409       cond = fold_convert (long_integer_type_node, cond);
 410       tmp = build_int_cst (long_integer_type_node, 0);
 411       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 412       cond = fold_convert (boolean_type_node, cond);
 413
 414       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 415       gfc_add_expr_to_block (pblock, tmp);
 416     }
 417 }
 418
 419
 420 /* Call malloc to allocate size bytes of memory, with special conditions:
 421       + if size < 0, generate a runtime error,
 422       + if size == 0, return a NULL pointer,
 423       + if malloc returns NULL, issue a runtime error.  */
 424 tree
 425 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 426 {
 427   tree tmp, msg, negative, zero, malloc_result, null_result, res;
 428   stmtblock_t block2;
 429
 430   size = gfc_evaluate_now (size, block);
 431
 432   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 433     size = fold_convert (size_type_node, size);
 434
 435   /* Create a variable to hold the result.  */
 436   res = gfc_create_var (pvoid_type_node, NULL);
 437
 438   /* size < 0 ?  */
 439   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 440                           build_int_cst (size_type_node, 0));
 441   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 442       ("Attempt to allocate a negative amount of memory."));
 443   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 444                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 445                      build_empty_stmt ());
 446   gfc_add_expr_to_block (block, tmp);
 447
 448   /* Call malloc and check the result.  */
 449   gfc_start_block (&block2);
 450   gfc_add_modify_expr (&block2, res,
 451                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 452                        size));
 453   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 454                              build_int_cst (pvoid_type_node, 0));
 455   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 456       ("Memory allocation failed"));
 457   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 458                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 459                      build_empty_stmt ());
 460   gfc_add_expr_to_block (&block2, tmp);
 461   malloc_result = gfc_finish_block (&block2);
 462
 463   /* size == 0  */
 464   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
 465                       build_int_cst (size_type_node, 0));
 466   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
 467                      build_int_cst (pvoid_type_node, 0));
 468   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
 469   gfc_add_expr_to_block (block, tmp);
 470
 471   if (type != NULL)
 472     res = fold_convert (type, res);
 473   return res;
 474 }
 475
 476 /* Allocate memory, using an optional status argument.
 477
 478    This function follows the following pseudo-code:
 479
 480     void *
 481     allocate (size_t size, integer_type* stat)
 482     {
 483       void *newmem;
 484
 485       if (stat)
 486         *stat = 0;
 487
 488       // The only time this can happen is the size wraps around.
 489       if (size < 0)
 490       {
 491         if (stat)
 492         {
 493           *stat = LIBERROR_ALLOCATION;
 494           newmem = NULL;
 495         }
 496         else
 497           runtime_error ("Attempt to allocate negative amount of memory. "
 498                          "Possible integer overflow");
 499       }
 500       else
 501       {
 502         newmem = malloc (MAX (size, 1));
 503         if (newmem == NULL)
 504         {
 505           if (stat)
 506             *stat = LIBERROR_ALLOCATION;
 507           else
 508             runtime_error ("Out of memory");
 509         }
 510       }
 511
 512       return newmem;
 513     }  */
 514 tree
 515 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 516 {
 517   stmtblock_t alloc_block;
 518   tree res, tmp, error, msg, cond;
 519   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 520
 521   /* Evaluate size only once, and make sure it has the right type.  */
 522   size = gfc_evaluate_now (size, block);
 523   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 524     size = fold_convert (size_type_node, size);
 525
 526   /* Create a variable to hold the result.  */
 527   res = gfc_create_var (pvoid_type_node, NULL);
 528
 529   /* Set the optional status variable to zero.  */
 530   if (status != NULL_TREE && !integer_zerop (status))
 531     {
 532       tmp = fold_build2 (MODIFY_EXPR, status_type,
 533                          build1 (INDIRECT_REF, status_type, status),
 534                          build_int_cst (status_type, 0));
 535       tmp = fold_build3 (COND_EXPR, void_type_node,
 536                          fold_build2 (NE_EXPR, boolean_type_node,
 537                                       status, build_int_cst (status_type, 0)),
 538                          tmp, build_empty_stmt ());
 539       gfc_add_expr_to_block (block, tmp);
 540     }
 541
 542   /* Generate the block of code handling (size < 0).  */
 543   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 544                         ("Attempt to allocate negative amount of memory. "
 545                          "Possible integer overflow"));
 546   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 547
 548   if (status != NULL_TREE && !integer_zerop (status))
 549     {
 550       /* Set the status variable if it's present.  */
 551       stmtblock_t set_status_block;
 552
 553       gfc_start_block (&set_status_block);
 554       gfc_add_modify_expr (&set_status_block,
 555                            build1 (INDIRECT_REF, status_type, status),
 556                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 557       gfc_add_modify_expr (&set_status_block, res,
 558                            build_int_cst (pvoid_type_node, 0));
 559
 560       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 561                          build_int_cst (status_type, 0));
 562       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 563                            gfc_finish_block (&set_status_block));
 564     }
 565
 566   /* The allocation itself.  */
 567   gfc_start_block (&alloc_block);
 568   gfc_add_modify_expr (&alloc_block, res,
 569                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 570                                         fold_build2 (MAX_EXPR, size_type_node,
 571                                                      size,
 572                                                      build_int_cst (size_type_node, 1))));
 573
 574   msg = gfc_build_addr_expr (pchar_type_node,
 575                              gfc_build_cstring_const ("Out of memory"));
 576   tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
 577
 578   if (status != NULL_TREE && !integer_zerop (status))
 579     {
 580       /* Set the status variable if it's present.  */
 581       tree tmp2;
 582
 583       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
 584                           build_int_cst (status_type, 0));
 585       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
 586                           build1 (INDIRECT_REF, status_type, status),
 587                           build_int_cst (status_type, LIBERROR_ALLOCATION));
 588       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
 589                          tmp2);
 590     }
 591
 592   tmp = fold_build3 (COND_EXPR, void_type_node,
 593                      fold_build2 (EQ_EXPR, boolean_type_node, res,
 594                                   build_int_cst (pvoid_type_node, 0)),
 595                      tmp, build_empty_stmt ());
 596   gfc_add_expr_to_block (&alloc_block, tmp);
 597
 598   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
 599                       build_int_cst (TREE_TYPE (size), 0));
 600   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
 601                      gfc_finish_block (&alloc_block));
 602   gfc_add_expr_to_block (block, tmp);
 603
 604   return res;
 605 }
 606
 607
 608 /* Generate code for an ALLOCATE statement when the argument is an
 609    allocatable array.  If the array is currently allocated, it is an
 610    error to allocate it again.
 611
 612    This function follows the following pseudo-code:
 613
 614     void *
 615     allocate_array (void *mem, size_t size, integer_type *stat)
 616     {
 617       if (mem == NULL)
 618         return allocate (size, stat);
 619       else
 620       {
 621         if (stat)
 622         {
 623           free (mem);
 624           mem = allocate (size, stat);
 625           *stat = LIBERROR_ALLOCATION;
 626           return mem;
 627         }
 628         else
 629           runtime_error ("Attempting to allocate already allocated array");
 630     }  */
 631 tree
 632 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 633                                 tree status)
 634 {
 635   stmtblock_t alloc_block;
 636   tree res, tmp, null_mem, alloc, error, msg;
 637   tree type = TREE_TYPE (mem);
 638
 639   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 640     size = fold_convert (size_type_node, size);
 641
 642   /* Create a variable to hold the result.  */
 643   res = gfc_create_var (pvoid_type_node, NULL);
 644   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
 645                           build_int_cst (type, 0));
 646
 647   /* If mem is NULL, we call gfc_allocate_with_status.  */
 648   gfc_start_block (&alloc_block);
 649   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 650   gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
 651   alloc = gfc_finish_block (&alloc_block);
 652
 653   /* Otherwise, we issue a runtime error or set the status variable.  */
 654   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 655                         ("Attempting to allocate already allocated array"));
 656   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 657
 658   if (status != NULL_TREE && !integer_zerop (status))
 659     {
 660       tree status_type = TREE_TYPE (TREE_TYPE (status));
 661       stmtblock_t set_status_block;
 662
 663       gfc_start_block (&set_status_block);
 664       tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 665                              fold_convert (pvoid_type_node, mem));
 666       gfc_add_expr_to_block (&set_status_block, tmp);
 667
 668       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 669       gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
 670
 671       gfc_add_modify_expr (&set_status_block,
 672                            build1 (INDIRECT_REF, status_type, status),
 673                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 674
 675       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 676                          build_int_cst (status_type, 0));
 677       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 678                            gfc_finish_block (&set_status_block));
 679     }
 680
 681   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
 682   gfc_add_expr_to_block (block, tmp);
 683
 684   return res;
 685 }
 686
 687
 688 /* Free a given variable, if it's not NULL.  */
 689 tree
 690 gfc_call_free (tree var)
 691 {
 692   stmtblock_t block;
 693   tree tmp, cond, call;
 694
 695   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 696     var = fold_convert (pvoid_type_node, var);
 697
 698   gfc_start_block (&block);
 699   var = gfc_evaluate_now (var, &block);
 700   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 701                       build_int_cst (pvoid_type_node, 0));
 702   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
 703   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 704                      build_empty_stmt ());
 705   gfc_add_expr_to_block (&block, tmp);
 706
 707   return gfc_finish_block (&block);
 708 }
 709
 710
 711
 712 /* User-deallocate; we emit the code directly from the front-end, and the
 713    logic is the same as the previous library function:
 714
 715     void
 716     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 717     {
 718       if (!pointer)
 719         {
 720           if (stat)
 721             *stat = 1;
 722           else
 723             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 724         }
 725       else
 726         {
 727           free (pointer);
 728           if (stat)
 729             *stat = 0;
 730         }
 731     }
 732
 733    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 734    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 735    even when no status variable is passed to us (this is used for
 736    unconditional deallocation generated by the front-end at end of
 737    each procedure).  */
 738 tree
 739 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
 740 {
 741   stmtblock_t null, non_null;
 742   tree cond, tmp, error, msg;
 743
 744   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 745                       build_int_cst (TREE_TYPE (pointer), 0));
 746
 747   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 748      we emit a runtime error.  */
 749   gfc_start_block (&null);
 750   if (!can_fail)
 751     {
 752       msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 753                         ("Attempt to DEALLOCATE unallocated memory."));
 754       error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 755     }
 756   else
 757     error = build_empty_stmt ();
 758
 759   if (status != NULL_TREE && !integer_zerop (status))
 760     {
 761       tree status_type = TREE_TYPE (TREE_TYPE (status));
 762       tree cond2;
 763
 764       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 765                            build_int_cst (TREE_TYPE (status), 0));
 766       tmp = fold_build2 (MODIFY_EXPR, status_type,
 767                          build1 (INDIRECT_REF, status_type, status),
 768                          build_int_cst (status_type, 1));
 769       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
 770     }
 771
 772   gfc_add_expr_to_block (&null, error);
 773
 774   /* When POINTER is not NULL, we free it.  */
 775   gfc_start_block (&non_null);
 776   tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 777                          fold_convert (pvoid_type_node, pointer));
 778   gfc_add_expr_to_block (&non_null, tmp);
 779
 780   if (status != NULL_TREE && !integer_zerop (status))
 781     {
 782       /* We set STATUS to zero if it is present.  */
 783       tree status_type = TREE_TYPE (TREE_TYPE (status));
 784       tree cond2;
 785
 786       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 787                            build_int_cst (TREE_TYPE (status), 0));
 788       tmp = fold_build2 (MODIFY_EXPR, status_type,
 789                          build1 (INDIRECT_REF, status_type, status),
 790                          build_int_cst (status_type, 0));
 791       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
 792                          build_empty_stmt ());
 793       gfc_add_expr_to_block (&non_null, tmp);
 794     }
 795
 796   return fold_build3 (COND_EXPR, void_type_node, cond,
 797                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 798 }
 799
 800
 801 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 802    following pseudo-code:
 803
 804 void *
 805 internal_realloc (void *mem, size_t size)
 806 {
 807   if (size < 0)
 808     runtime_error ("Attempt to allocate a negative amount of memory.");
 809   mem = realloc (mem, size);
 810   if (!mem && size != 0)
 811     _gfortran_os_error ("Out of memory");
 812
 813   if (size == 0)
 814     return NULL;
 815
 816   return mem;
 817 }  */
 818 tree
 819 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 820 {
 821   tree msg, res, negative, zero, null_result, tmp;
 822   tree type = TREE_TYPE (mem);
 823
 824   size = gfc_evaluate_now (size, block);
 825
 826   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 827     size = fold_convert (size_type_node, size);
 828
 829   /* Create a variable to hold the result.  */
 830   res = gfc_create_var (type, NULL);
 831
 832   /* size < 0 ?  */
 833   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 834                           build_int_cst (size_type_node, 0));
 835   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 836       ("Attempt to allocate a negative amount of memory."));
 837   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 838                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 839                      build_empty_stmt ());
 840   gfc_add_expr_to_block (block, tmp);
 841
 842   /* Call realloc and check the result.  */
 843   tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
 844                          fold_convert (pvoid_type_node, mem), size);
 845   gfc_add_modify_expr (block, res, fold_convert (type, tmp));
 846   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 847                              build_int_cst (pvoid_type_node, 0));
 848   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
 849                       build_int_cst (size_type_node, 0));
 850   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
 851                              zero);
 852   msg = gfc_build_addr_expr (pchar_type_node,
 853                              gfc_build_cstring_const ("Out of memory"));
 854   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 855                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 856                      build_empty_stmt ());
 857   gfc_add_expr_to_block (block, tmp);
 858
 859   /* if (size == 0) then the result is NULL.  */
 860   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
 861   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
 862                      build_empty_stmt ());
 863   gfc_add_expr_to_block (block, tmp);
 864
 865   return res;
 866 }
 867
 868 /* Add a statement to a block.  */
 869
 870 void
 871 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 872 {
 873   gcc_assert (block);
 874
 875   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 876     return;
 877
 878   if (block->head)
 879     {
 880       if (TREE_CODE (block->head) != STATEMENT_LIST)
 881         {
 882           tree tmp;
 883
 884           tmp = block->head;
 885           block->head = NULL_TREE;
 886           append_to_statement_list (tmp, &block->head);
 887         }
 888       append_to_statement_list (expr, &block->head);
 889     }
 890   else
 891     /* Don't bother creating a list if we only have a single statement.  */
 892     block->head = expr;
 893 }
 894
 895
 896 /* Add a block the end of a block.  */
 897
 898 void
 899 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 900 {
 901   gcc_assert (append);
 902   gcc_assert (!append->has_scope);
 903
 904   gfc_add_expr_to_block (block, append->head);
 905   append->head = NULL_TREE;
 906 }
 907
 908
 909 /* Get the current locus.  The structure may not be complete, and should
 910    only be used with gfc_set_backend_locus.  */
 911
 912 void
 913 gfc_get_backend_locus (locus * loc)
 914 {
 915   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 916 #ifdef USE_MAPPED_LOCATION
 917   loc->lb->location = input_location;
 918 #else
 919   loc->lb->linenum = input_line;
 920 #endif
 921   loc->lb->file = gfc_current_backend_file;
 922 }
 923
 924
 925 /* Set the current locus.  */
 926
 927 void
 928 gfc_set_backend_locus (locus * loc)
 929 {
 930   gfc_current_backend_file = loc->lb->file;
 931 #ifdef USE_MAPPED_LOCATION
 932   input_location = loc->lb->location;
 933 #else
 934   input_line = loc->lb->linenum;
 935   input_filename = loc->lb->file->filename;
 936 #endif
 937 }
 938
 939
 940 /* Translate an executable statement.  */
 941
 942 tree
 943 gfc_trans_code (gfc_code * code)
 944 {
 945   stmtblock_t block;
 946   tree res;
 947
 948   if (!code)
 949     return build_empty_stmt ();
 950
 951   gfc_start_block (&block);
 952
 953   /* Translate statements one by one to GIMPLE trees until we reach
 954      the end of this gfc_code branch.  */
 955   for (; code; code = code->next)
 956     {
 957       if (code->here != 0)
 958         {
 959           res = gfc_trans_label_here (code);
 960           gfc_add_expr_to_block (&block, res);
 961         }
 962
 963       switch (code->op)
 964         {
 965         case EXEC_NOP:
 966           res = NULL_TREE;
 967           break;
 968
 969         case EXEC_ASSIGN:
 970           res = gfc_trans_assign (code);
 971           break;
 972
 973         case EXEC_LABEL_ASSIGN:
 974           res = gfc_trans_label_assign (code);
 975           break;
 976
 977         case EXEC_POINTER_ASSIGN:
 978           res = gfc_trans_pointer_assign (code);
 979           break;
 980
 981         case EXEC_INIT_ASSIGN:
 982           res = gfc_trans_init_assign (code);
 983           break;
 984
 985         case EXEC_CONTINUE:
 986           res = NULL_TREE;
 987           break;
 988
 989         case EXEC_CYCLE:
 990           res = gfc_trans_cycle (code);
 991           break;
 992
 993         case EXEC_EXIT:
 994           res = gfc_trans_exit (code);
 995           break;
 996
 997         case EXEC_GOTO:
 998           res = gfc_trans_goto (code);
 999           break;
1000
1001         case EXEC_ENTRY:
1002           res = gfc_trans_entry (code);
1003           break;
1004
1005         case EXEC_PAUSE:
1006           res = gfc_trans_pause (code);
1007           break;
1008
1009         case EXEC_STOP:
1010           res = gfc_trans_stop (code);
1011           break;
1012
1013         case EXEC_CALL:
1014           res = gfc_trans_call (code, false);
1015           break;
1016
1017         case EXEC_ASSIGN_CALL:
1018           res = gfc_trans_call (code, true);
1019           break;
1020
1021         case EXEC_RETURN:
1022           res = gfc_trans_return (code);
1023           break;
1024
1025         case EXEC_IF:
1026           res = gfc_trans_if (code);
1027           break;
1028
1029         case EXEC_ARITHMETIC_IF:
1030           res = gfc_trans_arithmetic_if (code);
1031           break;
1032
1033         case EXEC_DO:
1034           res = gfc_trans_do (code);
1035           break;
1036
1037         case EXEC_DO_WHILE:
1038           res = gfc_trans_do_while (code);
1039           break;
1040
1041         case EXEC_SELECT:
1042           res = gfc_trans_select (code);
1043           break;
1044
1045         case EXEC_FLUSH:
1046           res = gfc_trans_flush (code);
1047           break;
1048
1049         case EXEC_FORALL:
1050           res = gfc_trans_forall (code);
1051           break;
1052
1053         case EXEC_WHERE:
1054           res = gfc_trans_where (code);
1055           break;
1056
1057         case EXEC_ALLOCATE:
1058           res = gfc_trans_allocate (code);
1059           break;
1060
1061         case EXEC_DEALLOCATE:
1062           res = gfc_trans_deallocate (code);
1063           break;
1064
1065         case EXEC_OPEN:
1066           res = gfc_trans_open (code);
1067           break;
1068
1069         case EXEC_CLOSE:
1070           res = gfc_trans_close (code);
1071           break;
1072
1073         case EXEC_READ:
1074           res = gfc_trans_read (code);
1075           break;
1076
1077         case EXEC_WRITE:
1078           res = gfc_trans_write (code);
1079           break;
1080
1081         case EXEC_IOLENGTH:
1082           res = gfc_trans_iolength (code);
1083           break;
1084
1085         case EXEC_BACKSPACE:
1086           res = gfc_trans_backspace (code);
1087           break;
1088
1089         case EXEC_ENDFILE:
1090           res = gfc_trans_endfile (code);
1091           break;
1092
1093         case EXEC_INQUIRE:
1094           res = gfc_trans_inquire (code);
1095           break;
1096
1097         case EXEC_REWIND:
1098           res = gfc_trans_rewind (code);
1099           break;
1100
1101         case EXEC_TRANSFER:
1102           res = gfc_trans_transfer (code);
1103           break;
1104
1105         case EXEC_DT_END:
1106           res = gfc_trans_dt_end (code);
1107           break;
1108
1109         case EXEC_OMP_ATOMIC:
1110         case EXEC_OMP_BARRIER:
1111         case EXEC_OMP_CRITICAL:
1112         case EXEC_OMP_DO:
1113         case EXEC_OMP_FLUSH:
1114         case EXEC_OMP_MASTER:
1115         case EXEC_OMP_ORDERED:
1116         case EXEC_OMP_PARALLEL:
1117         case EXEC_OMP_PARALLEL_DO:
1118         case EXEC_OMP_PARALLEL_SECTIONS:
1119         case EXEC_OMP_PARALLEL_WORKSHARE:
1120         case EXEC_OMP_SECTIONS:
1121         case EXEC_OMP_SINGLE:
1122         case EXEC_OMP_WORKSHARE:
1123           res = gfc_trans_omp_directive (code);
1124           break;
1125
1126         default:
1127           internal_error ("gfc_trans_code(): Bad statement code");
1128         }
1129
1130       gfc_set_backend_locus (&code->loc);
1131
1132       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1133         {
1134           if (TREE_CODE (res) == STATEMENT_LIST)
1135             annotate_all_with_locus (&res, input_location);
1136           else
1137             SET_EXPR_LOCATION (res, input_location);
1138
1139           /* Add the new statement to the block.  */
1140           gfc_add_expr_to_block (&block, res);
1141         }
1142     }
1143
1144   /* Return the finished block.  */
1145   return gfc_finish_block (&block);
1146 }
1147
1148
1149 /* This function is called after a complete program unit has been parsed
1150    and resolved.  */
1151
1152 void
1153 gfc_generate_code (gfc_namespace * ns)
1154 {
1155   if (ns->is_block_data)
1156     {
1157       gfc_generate_block_data (ns);
1158       return;
1159     }
1160
1161   gfc_generate_function_code (ns);
1162 }
1163
1164
1165 /* This function is called after a complete module has been parsed
1166    and resolved.  */
1167
1168 void
1169 gfc_generate_module_code (gfc_namespace * ns)
1170 {
1171   gfc_namespace *n;
1172
1173   gfc_generate_module_vars (ns);
1174
1175   /* We need to generate all module function prototypes first, to allow
1176      sibling calls.  */
1177   for (n = ns->contained; n; n = n->sibling)
1178     {
1179       if (!n->proc_name)
1180         continue;
1181
1182       gfc_create_function_decl (n);
1183     }
1184
1185   for (n = ns->contained; n; n = n->sibling)
1186     {
1187       if (!n->proc_name)
1188         continue;
1189
1190       gfc_generate_function_code (n);
1191     }
1192 }
1193