gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 "gimple.h"
  27 #include "tree-iterator.h"
  28 #include "ggc.h"
  29 #include "toplev.h"
  30 #include "defaults.h"
  31 #include "real.h"
  32 #include "flags.h"
  33 #include "gfortran.h"
  34 #include "trans.h"
  35 #include "trans-stmt.h"
  36 #include "trans-array.h"
  37 #include "trans-types.h"
  38 #include "trans-const.h"
  39
  40 /* Naming convention for backend interface code:
  41
  42    gfc_trans_*  translate gfc_code into STMT trees.
  43
  44    gfc_conv_*   expression conversion
  45
  46    gfc_get_*    get a backend tree representation of a decl or type  */
  47
  48 static gfc_file *gfc_current_backend_file;
  49
  50 const char gfc_msg_bounds[] = N_("Array bound mismatch");
  51 const char gfc_msg_fault[] = N_("Array reference out of bounds");
  52 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  53
  54
  55 /* Advance along TREE_CHAIN n times.  */
  56
  57 tree
  58 gfc_advance_chain (tree t, int n)
  59 {
  60   for (; n > 0; n--)
  61     {
  62       gcc_assert (t != NULL_TREE);
  63       t = TREE_CHAIN (t);
  64     }
  65   return t;
  66 }
  67
  68
  69 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  70
  71 tree
  72 gfc_chainon_list (tree list, tree add)
  73 {
  74   tree l;
  75
  76   l = tree_cons (NULL_TREE, add, NULL_TREE);
  77
  78   return chainon (list, l);
  79 }
  80
  81
  82 /* Strip off a legitimate source ending from the input
  83    string NAME of length LEN.  */
  84
  85 static inline void
  86 remove_suffix (char *name, int len)
  87 {
  88   int i;
  89
  90   for (i = 2; i < 8 && len > i; i++)
  91     {
  92       if (name[len - i] == '.')
  93         {
  94           name[len - i] = '\0';
  95           break;
  96         }
  97     }
  98 }
  99
 100
 101 /* Creates a variable declaration with a given TYPE.  */
 102
 103 tree
 104 gfc_create_var_np (tree type, const char *prefix)
 105 {
 106   tree t;
 107
 108   t = create_tmp_var_raw (type, prefix);
 109
 110   /* No warnings for anonymous variables.  */
 111   if (prefix == NULL)
 112     TREE_NO_WARNING (t) = 1;
 113
 114   return t;
 115 }
 116
 117
 118 /* Like above, but also adds it to the current scope.  */
 119
 120 tree
 121 gfc_create_var (tree type, const char *prefix)
 122 {
 123   tree tmp;
 124
 125   tmp = gfc_create_var_np (type, prefix);
 126
 127   pushdecl (tmp);
 128
 129   return tmp;
 130 }
 131
 132
 133 /* If the expression is not constant, evaluate it now.  We assign the
 134    result of the expression to an artificially created variable VAR, and
 135    return a pointer to the VAR_DECL node for this variable.  */
 136
 137 tree
 138 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 139 {
 140   tree var;
 141
 142   if (CONSTANT_CLASS_P (expr))
 143     return expr;
 144
 145   var = gfc_create_var (TREE_TYPE (expr), NULL);
 146   gfc_add_modify (pblock, var, expr);
 147
 148   return var;
 149 }
 150
 151
 152 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 153    A MODIFY_EXPR is an assignment:
 154    LHS <- RHS.  */
 155
 156 void
 157 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 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 (MODIFY_EXPR, void_type_node, lhs, rhs);
 171   gfc_add_expr_to_block (pblock, tmp);
 172 }
 173
 174
 175 /* Create a new scope/binding level and initialize a block.  Care must be
 176    taken when translating expressions as any temporaries will be placed in
 177    the innermost scope.  */
 178
 179 void
 180 gfc_start_block (stmtblock_t * block)
 181 {
 182   /* Start a new binding level.  */
 183   pushlevel (0);
 184   block->has_scope = 1;
 185
 186   /* The block is empty.  */
 187   block->head = NULL_TREE;
 188 }
 189
 190
 191 /* Initialize a block without creating a new scope.  */
 192
 193 void
 194 gfc_init_block (stmtblock_t * block)
 195 {
 196   block->head = NULL_TREE;
 197   block->has_scope = 0;
 198 }
 199
 200
 201 /* Sometimes we create a scope but it turns out that we don't actually
 202    need it.  This function merges the scope of BLOCK with its parent.
 203    Only variable decls will be merged, you still need to add the code.  */
 204
 205 void
 206 gfc_merge_block_scope (stmtblock_t * block)
 207 {
 208   tree decl;
 209   tree next;
 210
 211   gcc_assert (block->has_scope);
 212   block->has_scope = 0;
 213
 214   /* Remember the decls in this scope.  */
 215   decl = getdecls ();
 216   poplevel (0, 0, 0);
 217
 218   /* Add them to the parent scope.  */
 219   while (decl != NULL_TREE)
 220     {
 221       next = TREE_CHAIN (decl);
 222       TREE_CHAIN (decl) = NULL_TREE;
 223
 224       pushdecl (decl);
 225       decl = next;
 226     }
 227 }
 228
 229
 230 /* Finish a scope containing a block of statements.  */
 231
 232 tree
 233 gfc_finish_block (stmtblock_t * stmtblock)
 234 {
 235   tree decl;
 236   tree expr;
 237   tree block;
 238
 239   expr = stmtblock->head;
 240   if (!expr)
 241     expr = build_empty_stmt ();
 242
 243   stmtblock->head = NULL_TREE;
 244
 245   if (stmtblock->has_scope)
 246     {
 247       decl = getdecls ();
 248
 249       if (decl)
 250         {
 251           block = poplevel (1, 0, 0);
 252           expr = build3_v (BIND_EXPR, decl, expr, block);
 253         }
 254       else
 255         poplevel (0, 0, 0);
 256     }
 257
 258   return expr;
 259 }
 260
 261
 262 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 263    natural type is used.  */
 264
 265 tree
 266 gfc_build_addr_expr (tree type, tree t)
 267 {
 268   tree base_type = TREE_TYPE (t);
 269   tree natural_type;
 270
 271   if (type && POINTER_TYPE_P (type)
 272       && TREE_CODE (base_type) == ARRAY_TYPE
 273       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 274          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 275     {
 276       tree min_val = size_zero_node;
 277       tree type_domain = TYPE_DOMAIN (base_type);
 278       if (type_domain && TYPE_MIN_VALUE (type_domain))
 279         min_val = TYPE_MIN_VALUE (type_domain);
 280       t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
 281                         t, min_val, NULL_TREE, NULL_TREE));
 282       natural_type = type;
 283     }
 284   else
 285     natural_type = build_pointer_type (base_type);
 286
 287   if (TREE_CODE (t) == INDIRECT_REF)
 288     {
 289       if (!type)
 290         type = natural_type;
 291       t = TREE_OPERAND (t, 0);
 292       natural_type = TREE_TYPE (t);
 293     }
 294   else
 295     {
 296       if (DECL_P (t))
 297         TREE_ADDRESSABLE (t) = 1;
 298       t = fold_build1 (ADDR_EXPR, natural_type, t);
 299     }
 300
 301   if (type && natural_type != type)
 302     t = convert (type, t);
 303
 304   return t;
 305 }
 306
 307
 308 /* Build an ARRAY_REF with its natural type.  */
 309
 310 tree
 311 gfc_build_array_ref (tree base, tree offset, tree decl)
 312 {
 313   tree type = TREE_TYPE (base);
 314   tree tmp;
 315
 316   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 317   type = TREE_TYPE (type);
 318
 319   if (DECL_P (base))
 320     TREE_ADDRESSABLE (base) = 1;
 321
 322   /* Strip NON_LVALUE_EXPR nodes.  */
 323   STRIP_TYPE_NOPS (offset);
 324
 325   /* If the array reference is to a pointer, whose target contains a
 326      subreference, use the span that is stored with the backend decl
 327      and reference the element with pointer arithmetic.  */
 328   if (decl && (TREE_CODE (decl) == FIELD_DECL
 329                  || TREE_CODE (decl) == VAR_DECL
 330                  || TREE_CODE (decl) == PARM_DECL)
 331         && GFC_DECL_SUBREF_ARRAY_P (decl)
 332         && !integer_zerop (GFC_DECL_SPAN(decl)))
 333     {
 334       offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
 335                             offset, GFC_DECL_SPAN(decl));
 336       tmp = gfc_build_addr_expr (pvoid_type_node, base);
 337       tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
 338                          tmp, fold_convert (sizetype, offset));
 339       tmp = fold_convert (build_pointer_type (type), tmp);
 340       if (!TYPE_STRING_FLAG (type))
 341         tmp = build_fold_indirect_ref (tmp);
 342       return tmp;
 343     }
 344   else
 345     /* Otherwise use a straightforward array reference.  */
 346     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 347 }
 348
 349
 350 /* Generate a call to print a runtime error possibly including multiple
 351    arguments and a locus.  */
 352
 353 tree
 354 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
 355 {
 356   va_list ap;
 357
 358   va_start (ap, msgid);
 359   return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
 360 }
 361
 362 tree
 363 gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
 364                                 va_list ap)
 365 {
 366   stmtblock_t block;
 367   tree tmp;
 368   tree arg, arg2;
 369   tree *argarray;
 370   tree fntype;
 371   char *message;
 372   const char *p;
 373   int line, nargs, i;
 374
 375   /* Compute the number of extra arguments from the format string.  */
 376   for (p = msgid, nargs = 0; *p; p++)
 377     if (*p == '%')
 378       {
 379         p++;
 380         if (*p != '%')
 381           nargs++;
 382       }
 383
 384   /* The code to generate the error.  */
 385   gfc_start_block (&block);
 386
 387   if (where)
 388     {
 389       line = LOCATION_LINE (where->lb->location);
 390       asprintf (&message, "At line %d of file %s",  line,
 391                 where->lb->file->filename);
 392     }
 393   else
 394     asprintf (&message, "In file '%s', around line %d",
 395               gfc_source_file, input_line + 1);
 396
 397   arg = gfc_build_addr_expr (pchar_type_node,
 398                              gfc_build_localized_cstring_const (message));
 399   gfc_free(message);
 400
 401   asprintf (&message, "%s", _(msgid));
 402   arg2 = gfc_build_addr_expr (pchar_type_node,
 403                               gfc_build_localized_cstring_const (message));
 404   gfc_free(message);
 405
 406   /* Build the argument array.  */
 407   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
 408   argarray[0] = arg;
 409   argarray[1] = arg2;
 410   for (i = 0; i < nargs; i++)
 411     argarray[2 + i] = va_arg (ap, tree);
 412   va_end (ap);
 413
 414   /* Build the function call to runtime_(warning,error)_at; because of the
 415      variable number of arguments, we can't use build_call_expr directly.  */
 416   if (error)
 417     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 418   else
 419     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 420
 421   tmp = fold_builtin_call_array (TREE_TYPE (fntype),
 422                                  fold_build1 (ADDR_EXPR,
 423                                               build_pointer_type (fntype),
 424                                               error
 425                                               ? gfor_fndecl_runtime_error_at
 426                                               : gfor_fndecl_runtime_warning_at),
 427                                  nargs + 2, argarray);
 428   gfc_add_expr_to_block (&block, tmp);
 429
 430   return gfc_finish_block (&block);
 431 }
 432
 433
 434 /* Generate a runtime error if COND is true.  */
 435
 436 void
 437 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 438                          locus * where, const char * msgid, ...)
 439 {
 440   va_list ap;
 441   stmtblock_t block;
 442   tree body;
 443   tree tmp;
 444   tree tmpvar = NULL;
 445
 446   if (integer_zerop (cond))
 447     return;
 448
 449   if (once)
 450     {
 451        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
 452        TREE_STATIC (tmpvar) = 1;
 453        DECL_INITIAL (tmpvar) = boolean_true_node;
 454        gfc_add_expr_to_block (pblock, tmpvar);
 455     }
 456
 457   gfc_start_block (&block);
 458
 459   /* The code to generate the error.  */
 460   va_start (ap, msgid);
 461   gfc_add_expr_to_block (&block,
 462                          gfc_trans_runtime_error_vararg (error, where,
 463                                                          msgid, ap));
 464
 465   if (once)
 466     gfc_add_modify (&block, tmpvar, boolean_false_node);
 467
 468   body = gfc_finish_block (&block);
 469
 470   if (integer_onep (cond))
 471     {
 472       gfc_add_expr_to_block (pblock, body);
 473     }
 474   else
 475     {
 476       /* Tell the compiler that this isn't likely.  */
 477       if (once)
 478         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
 479                             cond);
 480       else
 481         cond = fold_convert (long_integer_type_node, cond);
 482
 483       tmp = build_int_cst (long_integer_type_node, 0);
 484       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 485       cond = fold_convert (boolean_type_node, cond);
 486
 487       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 488       gfc_add_expr_to_block (pblock, tmp);
 489     }
 490 }
 491
 492
 493 /* Call malloc to allocate size bytes of memory, with special conditions:
 494       + if size < 0, generate a runtime error,
 495       + if size == 0, return a malloced area of size 1,
 496       + if malloc returns NULL, issue a runtime error.  */
 497 tree
 498 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 499 {
 500   tree tmp, msg, negative, malloc_result, null_result, res;
 501   stmtblock_t block2;
 502
 503   size = gfc_evaluate_now (size, block);
 504
 505   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 506     size = fold_convert (size_type_node, size);
 507
 508   /* Create a variable to hold the result.  */
 509   res = gfc_create_var (pvoid_type_node, NULL);
 510
 511   /* size < 0 ?  */
 512   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 513                           build_int_cst (size_type_node, 0));
 514   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 515       ("Attempt to allocate a negative amount of memory."));
 516   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 517                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 518                      build_empty_stmt ());
 519   gfc_add_expr_to_block (block, tmp);
 520
 521   /* Call malloc and check the result.  */
 522   gfc_start_block (&block2);
 523
 524   size = fold_build2 (MAX_EXPR, size_type_node, size,
 525                       build_int_cst (size_type_node, 1));
 526
 527   gfc_add_modify (&block2, res,
 528                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 529                        size));
 530   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 531                              build_int_cst (pvoid_type_node, 0));
 532   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 533       ("Memory allocation failed"));
 534   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 535                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 536                      build_empty_stmt ());
 537   gfc_add_expr_to_block (&block2, tmp);
 538   malloc_result = gfc_finish_block (&block2);
 539
 540   gfc_add_expr_to_block (block, malloc_result);
 541
 542   if (type != NULL)
 543     res = fold_convert (type, res);
 544   return res;
 545 }
 546
 547 /* Allocate memory, using an optional status argument.
 548
 549    This function follows the following pseudo-code:
 550
 551     void *
 552     allocate (size_t size, integer_type* stat)
 553     {
 554       void *newmem;
 555
 556       if (stat)
 557         *stat = 0;
 558
 559       // The only time this can happen is the size wraps around.
 560       if (size < 0)
 561       {
 562         if (stat)
 563         {
 564           *stat = LIBERROR_ALLOCATION;
 565           newmem = NULL;
 566         }
 567         else
 568           runtime_error ("Attempt to allocate negative amount of memory. "
 569                          "Possible integer overflow");
 570       }
 571       else
 572       {
 573         newmem = malloc (MAX (size, 1));
 574         if (newmem == NULL)
 575         {
 576           if (stat)
 577             *stat = LIBERROR_ALLOCATION;
 578           else
 579             runtime_error ("Out of memory");
 580         }
 581       }
 582
 583       return newmem;
 584     }  */
 585 tree
 586 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 587 {
 588   stmtblock_t alloc_block;
 589   tree res, tmp, error, msg, cond;
 590   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 591
 592   /* Evaluate size only once, and make sure it has the right type.  */
 593   size = gfc_evaluate_now (size, block);
 594   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 595     size = fold_convert (size_type_node, size);
 596
 597   /* Create a variable to hold the result.  */
 598   res = gfc_create_var (pvoid_type_node, NULL);
 599
 600   /* Set the optional status variable to zero.  */
 601   if (status != NULL_TREE && !integer_zerop (status))
 602     {
 603       tmp = fold_build2 (MODIFY_EXPR, status_type,
 604                          fold_build1 (INDIRECT_REF, status_type, status),
 605                          build_int_cst (status_type, 0));
 606       tmp = fold_build3 (COND_EXPR, void_type_node,
 607                          fold_build2 (NE_EXPR, boolean_type_node,
 608                                       status, build_int_cst (status_type, 0)),
 609                          tmp, build_empty_stmt ());
 610       gfc_add_expr_to_block (block, tmp);
 611     }
 612
 613   /* Generate the block of code handling (size < 0).  */
 614   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 615                         ("Attempt to allocate negative amount of memory. "
 616                          "Possible integer overflow"));
 617   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 618
 619   if (status != NULL_TREE && !integer_zerop (status))
 620     {
 621       /* Set the status variable if it's present.  */
 622       stmtblock_t set_status_block;
 623
 624       gfc_start_block (&set_status_block);
 625       gfc_add_modify (&set_status_block,
 626                            fold_build1 (INDIRECT_REF, status_type, status),
 627                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 628       gfc_add_modify (&set_status_block, res,
 629                            build_int_cst (pvoid_type_node, 0));
 630
 631       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 632                          build_int_cst (status_type, 0));
 633       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 634                            gfc_finish_block (&set_status_block));
 635     }
 636
 637   /* The allocation itself.  */
 638   gfc_start_block (&alloc_block);
 639   gfc_add_modify (&alloc_block, res,
 640                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 641                                         fold_build2 (MAX_EXPR, size_type_node,
 642                                                      size,
 643                                                      build_int_cst (size_type_node, 1))));
 644
 645   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 646                                                 ("Out of memory"));
 647   tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
 648
 649   if (status != NULL_TREE && !integer_zerop (status))
 650     {
 651       /* Set the status variable if it's present.  */
 652       tree tmp2;
 653
 654       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
 655                           build_int_cst (status_type, 0));
 656       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
 657                           fold_build1 (INDIRECT_REF, status_type, status),
 658                           build_int_cst (status_type, LIBERROR_ALLOCATION));
 659       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
 660                          tmp2);
 661     }
 662
 663   tmp = fold_build3 (COND_EXPR, void_type_node,
 664                      fold_build2 (EQ_EXPR, boolean_type_node, res,
 665                                   build_int_cst (pvoid_type_node, 0)),
 666                      tmp, build_empty_stmt ());
 667   gfc_add_expr_to_block (&alloc_block, tmp);
 668
 669   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
 670                       build_int_cst (TREE_TYPE (size), 0));
 671   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
 672                      gfc_finish_block (&alloc_block));
 673   gfc_add_expr_to_block (block, tmp);
 674
 675   return res;
 676 }
 677
 678
 679 /* Generate code for an ALLOCATE statement when the argument is an
 680    allocatable array.  If the array is currently allocated, it is an
 681    error to allocate it again.
 682
 683    This function follows the following pseudo-code:
 684
 685     void *
 686     allocate_array (void *mem, size_t size, integer_type *stat)
 687     {
 688       if (mem == NULL)
 689         return allocate (size, stat);
 690       else
 691       {
 692         if (stat)
 693         {
 694           free (mem);
 695           mem = allocate (size, stat);
 696           *stat = LIBERROR_ALLOCATION;
 697           return mem;
 698         }
 699         else
 700           runtime_error ("Attempting to allocate already allocated array");
 701     }
 702
 703     expr must be set to the original expression being allocated for its locus
 704     and variable name in case a runtime error has to be printed.  */
 705 tree
 706 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 707                                 tree status, gfc_expr* expr)
 708 {
 709   stmtblock_t alloc_block;
 710   tree res, tmp, null_mem, alloc, error;
 711   tree type = TREE_TYPE (mem);
 712
 713   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 714     size = fold_convert (size_type_node, size);
 715
 716   /* Create a variable to hold the result.  */
 717   res = gfc_create_var (pvoid_type_node, NULL);
 718   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
 719                           build_int_cst (type, 0));
 720
 721   /* If mem is NULL, we call gfc_allocate_with_status.  */
 722   gfc_start_block (&alloc_block);
 723   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 724   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
 725   alloc = gfc_finish_block (&alloc_block);
 726
 727   /* Otherwise, we issue a runtime error or set the status variable.  */
 728   if (expr)
 729     {
 730       tree varname;
 731
 732       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 733       varname = gfc_build_cstring_const (expr->symtree->name);
 734       varname = gfc_build_addr_expr (pchar_type_node, varname);
 735
 736       error = gfc_trans_runtime_error (true, &expr->where,
 737                                        "Attempting to allocate already"
 738                                        " allocated array '%s'",
 739                                        varname);
 740     }
 741   else
 742     error = gfc_trans_runtime_error (true, NULL,
 743                                      "Attempting to allocate already allocated"
 744                                      "array");
 745
 746   if (status != NULL_TREE && !integer_zerop (status))
 747     {
 748       tree status_type = TREE_TYPE (TREE_TYPE (status));
 749       stmtblock_t set_status_block;
 750
 751       gfc_start_block (&set_status_block);
 752       tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 753                              fold_convert (pvoid_type_node, mem));
 754       gfc_add_expr_to_block (&set_status_block, tmp);
 755
 756       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 757       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 758
 759       gfc_add_modify (&set_status_block,
 760                            fold_build1 (INDIRECT_REF, status_type, status),
 761                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 762
 763       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 764                          build_int_cst (status_type, 0));
 765       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 766                            gfc_finish_block (&set_status_block));
 767     }
 768
 769   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
 770   gfc_add_expr_to_block (block, tmp);
 771
 772   return res;
 773 }
 774
 775
 776 /* Free a given variable, if it's not NULL.  */
 777 tree
 778 gfc_call_free (tree var)
 779 {
 780   stmtblock_t block;
 781   tree tmp, cond, call;
 782
 783   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 784     var = fold_convert (pvoid_type_node, var);
 785
 786   gfc_start_block (&block);
 787   var = gfc_evaluate_now (var, &block);
 788   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 789                       build_int_cst (pvoid_type_node, 0));
 790   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
 791   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 792                      build_empty_stmt ());
 793   gfc_add_expr_to_block (&block, tmp);
 794
 795   return gfc_finish_block (&block);
 796 }
 797
 798
 799
 800 /* User-deallocate; we emit the code directly from the front-end, and the
 801    logic is the same as the previous library function:
 802
 803     void
 804     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 805     {
 806       if (!pointer)
 807         {
 808           if (stat)
 809             *stat = 1;
 810           else
 811             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 812         }
 813       else
 814         {
 815           free (pointer);
 816           if (stat)
 817             *stat = 0;
 818         }
 819     }
 820
 821    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 822    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 823    even when no status variable is passed to us (this is used for
 824    unconditional deallocation generated by the front-end at end of
 825    each procedure).
 826
 827    If a runtime-message is possible, `expr' must point to the original
 828    expression being deallocated for its locus and variable name.  */
 829 tree
 830 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 831                             gfc_expr* expr)
 832 {
 833   stmtblock_t null, non_null;
 834   tree cond, tmp, error;
 835
 836   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 837                       build_int_cst (TREE_TYPE (pointer), 0));
 838
 839   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 840      we emit a runtime error.  */
 841   gfc_start_block (&null);
 842   if (!can_fail)
 843     {
 844       tree varname;
 845
 846       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 847
 848       varname = gfc_build_cstring_const (expr->symtree->name);
 849       varname = gfc_build_addr_expr (pchar_type_node, varname);
 850
 851       error = gfc_trans_runtime_error (true, &expr->where,
 852                                        "Attempt to DEALLOCATE unallocated '%s'",
 853                                        varname);
 854     }
 855   else
 856     error = build_empty_stmt ();
 857
 858   if (status != NULL_TREE && !integer_zerop (status))
 859     {
 860       tree status_type = TREE_TYPE (TREE_TYPE (status));
 861       tree cond2;
 862
 863       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 864                            build_int_cst (TREE_TYPE (status), 0));
 865       tmp = fold_build2 (MODIFY_EXPR, status_type,
 866                          fold_build1 (INDIRECT_REF, status_type, status),
 867                          build_int_cst (status_type, 1));
 868       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
 869     }
 870
 871   gfc_add_expr_to_block (&null, error);
 872
 873   /* When POINTER is not NULL, we free it.  */
 874   gfc_start_block (&non_null);
 875   tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 876                          fold_convert (pvoid_type_node, pointer));
 877   gfc_add_expr_to_block (&non_null, tmp);
 878
 879   if (status != NULL_TREE && !integer_zerop (status))
 880     {
 881       /* We set STATUS to zero if it is present.  */
 882       tree status_type = TREE_TYPE (TREE_TYPE (status));
 883       tree cond2;
 884
 885       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 886                            build_int_cst (TREE_TYPE (status), 0));
 887       tmp = fold_build2 (MODIFY_EXPR, status_type,
 888                          fold_build1 (INDIRECT_REF, status_type, status),
 889                          build_int_cst (status_type, 0));
 890       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
 891                          build_empty_stmt ());
 892       gfc_add_expr_to_block (&non_null, tmp);
 893     }
 894
 895   return fold_build3 (COND_EXPR, void_type_node, cond,
 896                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 897 }
 898
 899
 900 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 901    following pseudo-code:
 902
 903 void *
 904 internal_realloc (void *mem, size_t size)
 905 {
 906   if (size < 0)
 907     runtime_error ("Attempt to allocate a negative amount of memory.");
 908   res = realloc (mem, size);
 909   if (!res && size != 0)
 910     _gfortran_os_error ("Out of memory");
 911
 912   if (size == 0)
 913     return NULL;
 914
 915   return res;
 916 }  */
 917 tree
 918 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 919 {
 920   tree msg, res, negative, nonzero, zero, null_result, tmp;
 921   tree type = TREE_TYPE (mem);
 922
 923   size = gfc_evaluate_now (size, block);
 924
 925   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 926     size = fold_convert (size_type_node, size);
 927
 928   /* Create a variable to hold the result.  */
 929   res = gfc_create_var (type, NULL);
 930
 931   /* size < 0 ?  */
 932   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 933                           build_int_cst (size_type_node, 0));
 934   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 935       ("Attempt to allocate a negative amount of memory."));
 936   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 937                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 938                      build_empty_stmt ());
 939   gfc_add_expr_to_block (block, tmp);
 940
 941   /* Call realloc and check the result.  */
 942   tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
 943                          fold_convert (pvoid_type_node, mem), size);
 944   gfc_add_modify (block, res, fold_convert (type, tmp));
 945   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 946                              build_int_cst (pvoid_type_node, 0));
 947   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
 948                          build_int_cst (size_type_node, 0));
 949   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
 950                              nonzero);
 951   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 952                                                 ("Out of memory"));
 953   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 954                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 955                      build_empty_stmt ());
 956   gfc_add_expr_to_block (block, tmp);
 957
 958   /* if (size == 0) then the result is NULL.  */
 959   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
 960   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
 961   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
 962                      build_empty_stmt ());
 963   gfc_add_expr_to_block (block, tmp);
 964
 965   return res;
 966 }
 967
 968 /* Add a statement to a block.  */
 969
 970 void
 971 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 972 {
 973   gcc_assert (block);
 974
 975   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 976     return;
 977
 978   if (block->head)
 979     {
 980       if (TREE_CODE (block->head) != STATEMENT_LIST)
 981         {
 982           tree tmp;
 983
 984           tmp = block->head;
 985           block->head = NULL_TREE;
 986           append_to_statement_list (tmp, &block->head);
 987         }
 988       append_to_statement_list (expr, &block->head);
 989     }
 990   else
 991     /* Don't bother creating a list if we only have a single statement.  */
 992     block->head = expr;
 993 }
 994
 995
 996 /* Add a block the end of a block.  */
 997
 998 void
 999 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1000 {
1001   gcc_assert (append);
1002   gcc_assert (!append->has_scope);
1003
1004   gfc_add_expr_to_block (block, append->head);
1005   append->head = NULL_TREE;
1006 }
1007
1008
1009 /* Get the current locus.  The structure may not be complete, and should
1010    only be used with gfc_set_backend_locus.  */
1011
1012 void
1013 gfc_get_backend_locus (locus * loc)
1014 {
1015   loc->lb = XCNEW (gfc_linebuf);
1016   loc->lb->location = input_location;
1017   loc->lb->file = gfc_current_backend_file;
1018 }
1019
1020
1021 /* Set the current locus.  */
1022
1023 void
1024 gfc_set_backend_locus (locus * loc)
1025 {
1026   gfc_current_backend_file = loc->lb->file;
1027   input_location = loc->lb->location;
1028 }
1029
1030
1031 /* Translate an executable statement.  */
1032
1033 tree
1034 gfc_trans_code (gfc_code * code)
1035 {
1036   stmtblock_t block;
1037   tree res;
1038
1039   if (!code)
1040     return build_empty_stmt ();
1041
1042   gfc_start_block (&block);
1043
1044   /* Translate statements one by one into GENERIC trees until we reach
1045      the end of this gfc_code branch.  */
1046   for (; code; code = code->next)
1047     {
1048       if (code->here != 0)
1049         {
1050           res = gfc_trans_label_here (code);
1051           gfc_add_expr_to_block (&block, res);
1052         }
1053
1054       switch (code->op)
1055         {
1056         case EXEC_NOP:
1057           res = NULL_TREE;
1058           break;
1059
1060         case EXEC_ASSIGN:
1061           res = gfc_trans_assign (code);
1062           break;
1063
1064         case EXEC_LABEL_ASSIGN:
1065           res = gfc_trans_label_assign (code);
1066           break;
1067
1068         case EXEC_POINTER_ASSIGN:
1069           res = gfc_trans_pointer_assign (code);
1070           break;
1071
1072         case EXEC_INIT_ASSIGN:
1073           res = gfc_trans_init_assign (code);
1074           break;
1075
1076         case EXEC_CONTINUE:
1077           res = NULL_TREE;
1078           break;
1079
1080         case EXEC_CYCLE:
1081           res = gfc_trans_cycle (code);
1082           break;
1083
1084         case EXEC_EXIT:
1085           res = gfc_trans_exit (code);
1086           break;
1087
1088         case EXEC_GOTO:
1089           res = gfc_trans_goto (code);
1090           break;
1091
1092         case EXEC_ENTRY:
1093           res = gfc_trans_entry (code);
1094           break;
1095
1096         case EXEC_PAUSE:
1097           res = gfc_trans_pause (code);
1098           break;
1099
1100         case EXEC_STOP:
1101           res = gfc_trans_stop (code);
1102           break;
1103
1104         case EXEC_CALL:
1105           res = gfc_trans_call (code, false);
1106           break;
1107
1108         case EXEC_ASSIGN_CALL:
1109           res = gfc_trans_call (code, true);
1110           break;
1111
1112         case EXEC_RETURN:
1113           res = gfc_trans_return (code);
1114           break;
1115
1116         case EXEC_IF:
1117           res = gfc_trans_if (code);
1118           break;
1119
1120         case EXEC_ARITHMETIC_IF:
1121           res = gfc_trans_arithmetic_if (code);
1122           break;
1123
1124         case EXEC_DO:
1125           res = gfc_trans_do (code);
1126           break;
1127
1128         case EXEC_DO_WHILE:
1129           res = gfc_trans_do_while (code);
1130           break;
1131
1132         case EXEC_SELECT:
1133           res = gfc_trans_select (code);
1134           break;
1135
1136         case EXEC_FLUSH:
1137           res = gfc_trans_flush (code);
1138           break;
1139
1140         case EXEC_FORALL:
1141           res = gfc_trans_forall (code);
1142           break;
1143
1144         case EXEC_WHERE:
1145           res = gfc_trans_where (code);
1146           break;
1147
1148         case EXEC_ALLOCATE:
1149           res = gfc_trans_allocate (code);
1150           break;
1151
1152         case EXEC_DEALLOCATE:
1153           res = gfc_trans_deallocate (code);
1154           break;
1155
1156         case EXEC_OPEN:
1157           res = gfc_trans_open (code);
1158           break;
1159
1160         case EXEC_CLOSE:
1161           res = gfc_trans_close (code);
1162           break;
1163
1164         case EXEC_READ:
1165           res = gfc_trans_read (code);
1166           break;
1167
1168         case EXEC_WRITE:
1169           res = gfc_trans_write (code);
1170           break;
1171
1172         case EXEC_IOLENGTH:
1173           res = gfc_trans_iolength (code);
1174           break;
1175
1176         case EXEC_BACKSPACE:
1177           res = gfc_trans_backspace (code);
1178           break;
1179
1180         case EXEC_ENDFILE:
1181           res = gfc_trans_endfile (code);
1182           break;
1183
1184         case EXEC_INQUIRE:
1185           res = gfc_trans_inquire (code);
1186           break;
1187
1188         case EXEC_WAIT:
1189           res = gfc_trans_wait (code);
1190           break;
1191
1192         case EXEC_REWIND:
1193           res = gfc_trans_rewind (code);
1194           break;
1195
1196         case EXEC_TRANSFER:
1197           res = gfc_trans_transfer (code);
1198           break;
1199
1200         case EXEC_DT_END:
1201           res = gfc_trans_dt_end (code);
1202           break;
1203
1204         case EXEC_OMP_ATOMIC:
1205         case EXEC_OMP_BARRIER:
1206         case EXEC_OMP_CRITICAL:
1207         case EXEC_OMP_DO:
1208         case EXEC_OMP_FLUSH:
1209         case EXEC_OMP_MASTER:
1210         case EXEC_OMP_ORDERED:
1211         case EXEC_OMP_PARALLEL:
1212         case EXEC_OMP_PARALLEL_DO:
1213         case EXEC_OMP_PARALLEL_SECTIONS:
1214         case EXEC_OMP_PARALLEL_WORKSHARE:
1215         case EXEC_OMP_SECTIONS:
1216         case EXEC_OMP_SINGLE:
1217         case EXEC_OMP_TASK:
1218         case EXEC_OMP_TASKWAIT:
1219         case EXEC_OMP_WORKSHARE:
1220           res = gfc_trans_omp_directive (code);
1221           break;
1222
1223         default:
1224           internal_error ("gfc_trans_code(): Bad statement code");
1225         }
1226
1227       gfc_set_backend_locus (&code->loc);
1228
1229       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1230         {
1231           if (TREE_CODE (res) == STATEMENT_LIST)
1232             tree_annotate_all_with_location (&res, input_location);
1233           else
1234             SET_EXPR_LOCATION (res, input_location);
1235
1236           /* Add the new statement to the block.  */
1237           gfc_add_expr_to_block (&block, res);
1238         }
1239     }
1240
1241   /* Return the finished block.  */
1242   return gfc_finish_block (&block);
1243 }
1244
1245
1246 /* This function is called after a complete program unit has been parsed
1247    and resolved.  */
1248
1249 void
1250 gfc_generate_code (gfc_namespace * ns)
1251 {
1252   if (ns->is_block_data)
1253     {
1254       gfc_generate_block_data (ns);
1255       return;
1256     }
1257
1258   gfc_generate_function_code (ns);
1259 }
1260
1261
1262 /* This function is called after a complete module has been parsed
1263    and resolved.  */
1264
1265 void
1266 gfc_generate_module_code (gfc_namespace * ns)
1267 {
1268   gfc_namespace *n;
1269   struct module_htab_entry *entry;
1270
1271   gcc_assert (ns->proc_name->backend_decl == NULL);
1272   ns->proc_name->backend_decl
1273     = build_decl (NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1274                   void_type_node);
1275   gfc_set_decl_location (ns->proc_name->backend_decl,
1276                          &ns->proc_name->declared_at);
1277   entry = gfc_find_module (ns->proc_name->name);
1278   if (entry->namespace_decl)
1279     /* Buggy sourcecode, using a module before defining it?  */
1280     htab_empty (entry->decls);
1281   entry->namespace_decl = ns->proc_name->backend_decl;
1282
1283   gfc_generate_module_vars (ns);
1284
1285   /* We need to generate all module function prototypes first, to allow
1286      sibling calls.  */
1287   for (n = ns->contained; n; n = n->sibling)
1288     {
1289       gfc_entry_list *el;
1290
1291       if (!n->proc_name)
1292         continue;
1293
1294       gfc_create_function_decl (n);
1295       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1296       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1297       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1298       for (el = ns->entries; el; el = el->next)
1299         {
1300           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1301           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1302           gfc_module_add_decl (entry, el->sym->backend_decl);
1303         }
1304     }
1305
1306   for (n = ns->contained; n; n = n->sibling)
1307     {
1308       if (!n->proc_name)
1309         continue;
1310
1311       gfc_generate_function_code (n);
1312     }
1313 }
1314