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 2, 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 COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "coretypes.h"
  26 #include "tree.h"
  27 #include "tree-gimple.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 char gfc_msg_bounds[] = N_("Array bound mismatch");
  51 char gfc_msg_fault[] = N_("Array reference out of bounds");
  52 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   return create_tmp_var_raw (type, prefix);
 107 }
 108
 109
 110 /* Like above, but also adds it to the current scope.  */
 111
 112 tree
 113 gfc_create_var (tree type, const char *prefix)
 114 {
 115   tree tmp;
 116
 117   tmp = gfc_create_var_np (type, prefix);
 118
 119   pushdecl (tmp);
 120
 121   return tmp;
 122 }
 123
 124
 125 /* If the an expression is not constant, evaluate it now.  We assign the
 126    result of the expression to an artificially created variable VAR, and
 127    return a pointer to the VAR_DECL node for this variable.  */
 128
 129 tree
 130 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 131 {
 132   tree var;
 133
 134   if (CONSTANT_CLASS_P (expr))
 135     return expr;
 136
 137   var = gfc_create_var (TREE_TYPE (expr), NULL);
 138   gfc_add_modify_expr (pblock, var, expr);
 139
 140   return var;
 141 }
 142
 143
 144 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
 145    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
 146    LHS <- RHS.  */
 147
 148 void
 149 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
 150                 bool tuples_p)
 151 {
 152   tree tmp;
 153
 154 #ifdef ENABLE_CHECKING
 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 (TREE_TYPE (rhs) == TREE_TYPE (lhs)
 160               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 161 #endif
 162
 163   tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
 164                      void_type_node, lhs, rhs);
 165   gfc_add_expr_to_block (pblock, tmp);
 166 }
 167
 168
 169 /* Create a new scope/binding level and initialize a block.  Care must be
 170    taken when translating expressions as any temporaries will be placed in
 171    the innermost scope.  */
 172
 173 void
 174 gfc_start_block (stmtblock_t * block)
 175 {
 176   /* Start a new binding level.  */
 177   pushlevel (0);
 178   block->has_scope = 1;
 179
 180   /* The block is empty.  */
 181   block->head = NULL_TREE;
 182 }
 183
 184
 185 /* Initialize a block without creating a new scope.  */
 186
 187 void
 188 gfc_init_block (stmtblock_t * block)
 189 {
 190   block->head = NULL_TREE;
 191   block->has_scope = 0;
 192 }
 193
 194
 195 /* Sometimes we create a scope but it turns out that we don't actually
 196    need it.  This function merges the scope of BLOCK with its parent.
 197    Only variable decls will be merged, you still need to add the code.  */
 198
 199 void
 200 gfc_merge_block_scope (stmtblock_t * block)
 201 {
 202   tree decl;
 203   tree next;
 204
 205   gcc_assert (block->has_scope);
 206   block->has_scope = 0;
 207
 208   /* Remember the decls in this scope.  */
 209   decl = getdecls ();
 210   poplevel (0, 0, 0);
 211
 212   /* Add them to the parent scope.  */
 213   while (decl != NULL_TREE)
 214     {
 215       next = TREE_CHAIN (decl);
 216       TREE_CHAIN (decl) = NULL_TREE;
 217
 218       pushdecl (decl);
 219       decl = next;
 220     }
 221 }
 222
 223
 224 /* Finish a scope containing a block of statements.  */
 225
 226 tree
 227 gfc_finish_block (stmtblock_t * stmtblock)
 228 {
 229   tree decl;
 230   tree expr;
 231   tree block;
 232
 233   expr = stmtblock->head;
 234   if (!expr)
 235     expr = build_empty_stmt ();
 236
 237   stmtblock->head = NULL_TREE;
 238
 239   if (stmtblock->has_scope)
 240     {
 241       decl = getdecls ();
 242
 243       if (decl)
 244         {
 245           block = poplevel (1, 0, 0);
 246           expr = build3_v (BIND_EXPR, decl, expr, block);
 247         }
 248       else
 249         poplevel (0, 0, 0);
 250     }
 251
 252   return expr;
 253 }
 254
 255
 256 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 257    natural type is used.  */
 258
 259 tree
 260 gfc_build_addr_expr (tree type, tree t)
 261 {
 262   tree base_type = TREE_TYPE (t);
 263   tree natural_type;
 264
 265   if (type && POINTER_TYPE_P (type)
 266       && TREE_CODE (base_type) == ARRAY_TYPE
 267       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 268          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 269     natural_type = type;
 270   else
 271     natural_type = build_pointer_type (base_type);
 272
 273   if (TREE_CODE (t) == INDIRECT_REF)
 274     {
 275       if (!type)
 276         type = natural_type;
 277       t = TREE_OPERAND (t, 0);
 278       natural_type = TREE_TYPE (t);
 279     }
 280   else
 281     {
 282       if (DECL_P (t))
 283         TREE_ADDRESSABLE (t) = 1;
 284       t = build1 (ADDR_EXPR, natural_type, t);
 285     }
 286
 287   if (type && natural_type != type)
 288     t = convert (type, t);
 289
 290   return t;
 291 }
 292
 293
 294 /* Build an ARRAY_REF with its natural type.  */
 295
 296 tree
 297 gfc_build_array_ref (tree base, tree offset)
 298 {
 299   tree type = TREE_TYPE (base);
 300   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 301   type = TREE_TYPE (type);
 302
 303   if (DECL_P (base))
 304     TREE_ADDRESSABLE (base) = 1;
 305
 306   /* Strip NON_LVALUE_EXPR nodes.  */
 307   STRIP_TYPE_NOPS (offset);
 308
 309   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 310 }
 311
 312
 313 /* Generate a runtime error if COND is true.  */
 314
 315 void
 316 gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
 317                          locus * where)
 318 {
 319   stmtblock_t block;
 320   tree body;
 321   tree tmp;
 322   tree arg, arg2;
 323   char *message;
 324   int line;
 325
 326   if (integer_zerop (cond))
 327     return;
 328
 329   /* The code to generate the error.  */
 330   gfc_start_block (&block);
 331
 332   if (where)
 333     {
 334 #ifdef USE_MAPPED_LOCATION
 335       line = LOCATION_LINE (where->lb->location);
 336 #else
 337       line = where->lb->linenum;
 338 #endif
 339       asprintf (&message, "At line %d of file %s",  line,
 340                 where->lb->file->filename);
 341     }
 342   else
 343     asprintf (&message, "In file '%s', around line %d",
 344               gfc_source_file, input_line + 1);
 345
 346   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 347   gfc_free(message);
 348
 349   asprintf (&message, "%s", _(msgid));
 350   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 351   gfc_free(message);
 352
 353   tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2);
 354   gfc_add_expr_to_block (&block, tmp);
 355
 356   body = gfc_finish_block (&block);
 357
 358   if (integer_onep (cond))
 359     {
 360       gfc_add_expr_to_block (pblock, body);
 361     }
 362   else
 363     {
 364       /* Tell the compiler that this isn't likely.  */
 365       cond = fold_convert (long_integer_type_node, cond);
 366       tmp = build_int_cst (long_integer_type_node, 0);
 367       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 368       cond = fold_convert (boolean_type_node, cond);
 369
 370       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 371       gfc_add_expr_to_block (pblock, tmp);
 372     }
 373 }
 374
 375
 376 /* Call malloc to allocate size bytes of memory, with special conditions:
 377       + if size < 0, generate a runtime error,
 378       + if size == 0, return a NULL pointer,
 379       + if malloc returns NULL, issue a runtime error.  */
 380 tree
 381 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 382 {
 383   tree tmp, msg, negative, zero, malloc_result, null_result, res;
 384   stmtblock_t block2;
 385
 386   size = gfc_evaluate_now (size, block);
 387
 388   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 389     size = fold_convert (size_type_node, size);
 390
 391   /* Create a variable to hold the result.  */
 392   res = gfc_create_var (pvoid_type_node, NULL);
 393
 394   /* size < 0 ?  */
 395   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 396                           build_int_cst (size_type_node, 0));
 397   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 398       ("Attempt to allocate a negative amount of memory."));
 399   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 400                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 401                      build_empty_stmt ());
 402   gfc_add_expr_to_block (block, tmp);
 403
 404   /* Call malloc and check the result.  */
 405   gfc_start_block (&block2);
 406   gfc_add_modify_expr (&block2, res,
 407                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 408                        size));
 409   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 410                              build_int_cst (pvoid_type_node, 0));
 411   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 412       ("Memory allocation failed"));
 413   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 414                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 415                      build_empty_stmt ());
 416   gfc_add_expr_to_block (&block2, tmp);
 417   malloc_result = gfc_finish_block (&block2);
 418
 419   /* size == 0  */
 420   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
 421                       build_int_cst (size_type_node, 0));
 422   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
 423                      build_int_cst (pvoid_type_node, 0));
 424   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
 425   gfc_add_expr_to_block (block, tmp);
 426
 427   if (type != NULL)
 428     res = fold_convert (type, res);
 429   return res;
 430 }
 431
 432
 433 /* Free a given variable, if it's not NULL.  */
 434 tree
 435 gfc_call_free (tree var)
 436 {
 437   stmtblock_t block;
 438   tree tmp, cond, call;
 439
 440   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 441     var = fold_convert (pvoid_type_node, var);
 442
 443   gfc_start_block (&block);
 444   var = gfc_evaluate_now (var, &block);
 445   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 446                       build_int_cst (pvoid_type_node, 0));
 447   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
 448   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 449                      build_empty_stmt ());
 450   gfc_add_expr_to_block (&block, tmp);
 451
 452   return gfc_finish_block (&block);
 453 }
 454
 455
 456 /* Add a statement to a block.  */
 457
 458 void
 459 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 460 {
 461   gcc_assert (block);
 462
 463   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 464     return;
 465
 466   if (block->head)
 467     {
 468       if (TREE_CODE (block->head) != STATEMENT_LIST)
 469         {
 470           tree tmp;
 471
 472           tmp = block->head;
 473           block->head = NULL_TREE;
 474           append_to_statement_list (tmp, &block->head);
 475         }
 476       append_to_statement_list (expr, &block->head);
 477     }
 478   else
 479     /* Don't bother creating a list if we only have a single statement.  */
 480     block->head = expr;
 481 }
 482
 483
 484 /* Add a block the end of a block.  */
 485
 486 void
 487 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 488 {
 489   gcc_assert (append);
 490   gcc_assert (!append->has_scope);
 491
 492   gfc_add_expr_to_block (block, append->head);
 493   append->head = NULL_TREE;
 494 }
 495
 496
 497 /* Get the current locus.  The structure may not be complete, and should
 498    only be used with gfc_set_backend_locus.  */
 499
 500 void
 501 gfc_get_backend_locus (locus * loc)
 502 {
 503   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 504 #ifdef USE_MAPPED_LOCATION
 505   loc->lb->location = input_location;
 506 #else
 507   loc->lb->linenum = input_line;
 508 #endif
 509   loc->lb->file = gfc_current_backend_file;
 510 }
 511
 512
 513 /* Set the current locus.  */
 514
 515 void
 516 gfc_set_backend_locus (locus * loc)
 517 {
 518   gfc_current_backend_file = loc->lb->file;
 519 #ifdef USE_MAPPED_LOCATION
 520   input_location = loc->lb->location;
 521 #else
 522   input_line = loc->lb->linenum;
 523   input_filename = loc->lb->file->filename;
 524 #endif
 525 }
 526
 527
 528 /* Translate an executable statement.  */
 529
 530 tree
 531 gfc_trans_code (gfc_code * code)
 532 {
 533   stmtblock_t block;
 534   tree res;
 535
 536   if (!code)
 537     return build_empty_stmt ();
 538
 539   gfc_start_block (&block);
 540
 541   /* Translate statements one by one to GIMPLE trees until we reach
 542      the end of this gfc_code branch.  */
 543   for (; code; code = code->next)
 544     {
 545       if (code->here != 0)
 546         {
 547           res = gfc_trans_label_here (code);
 548           gfc_add_expr_to_block (&block, res);
 549         }
 550
 551       switch (code->op)
 552         {
 553         case EXEC_NOP:
 554           res = NULL_TREE;
 555           break;
 556
 557         case EXEC_ASSIGN:
 558           res = gfc_trans_assign (code);
 559           break;
 560
 561         case EXEC_LABEL_ASSIGN:
 562           res = gfc_trans_label_assign (code);
 563           break;
 564
 565         case EXEC_POINTER_ASSIGN:
 566           res = gfc_trans_pointer_assign (code);
 567           break;
 568
 569         case EXEC_INIT_ASSIGN:
 570           res = gfc_trans_init_assign (code);
 571           break;
 572
 573         case EXEC_CONTINUE:
 574           res = NULL_TREE;
 575           break;
 576
 577         case EXEC_CYCLE:
 578           res = gfc_trans_cycle (code);
 579           break;
 580
 581         case EXEC_EXIT:
 582           res = gfc_trans_exit (code);
 583           break;
 584
 585         case EXEC_GOTO:
 586           res = gfc_trans_goto (code);
 587           break;
 588
 589         case EXEC_ENTRY:
 590           res = gfc_trans_entry (code);
 591           break;
 592
 593         case EXEC_PAUSE:
 594           res = gfc_trans_pause (code);
 595           break;
 596
 597         case EXEC_STOP:
 598           res = gfc_trans_stop (code);
 599           break;
 600
 601         case EXEC_CALL:
 602           res = gfc_trans_call (code, false);
 603           break;
 604
 605         case EXEC_ASSIGN_CALL:
 606           res = gfc_trans_call (code, true);
 607           break;
 608
 609         case EXEC_RETURN:
 610           res = gfc_trans_return (code);
 611           break;
 612
 613         case EXEC_IF:
 614           res = gfc_trans_if (code);
 615           break;
 616
 617         case EXEC_ARITHMETIC_IF:
 618           res = gfc_trans_arithmetic_if (code);
 619           break;
 620
 621         case EXEC_DO:
 622           res = gfc_trans_do (code);
 623           break;
 624
 625         case EXEC_DO_WHILE:
 626           res = gfc_trans_do_while (code);
 627           break;
 628
 629         case EXEC_SELECT:
 630           res = gfc_trans_select (code);
 631           break;
 632
 633         case EXEC_FLUSH:
 634           res = gfc_trans_flush (code);
 635           break;
 636
 637         case EXEC_FORALL:
 638           res = gfc_trans_forall (code);
 639           break;
 640
 641         case EXEC_WHERE:
 642           res = gfc_trans_where (code);
 643           break;
 644
 645         case EXEC_ALLOCATE:
 646           res = gfc_trans_allocate (code);
 647           break;
 648
 649         case EXEC_DEALLOCATE:
 650           res = gfc_trans_deallocate (code);
 651           break;
 652
 653         case EXEC_OPEN:
 654           res = gfc_trans_open (code);
 655           break;
 656
 657         case EXEC_CLOSE:
 658           res = gfc_trans_close (code);
 659           break;
 660
 661         case EXEC_READ:
 662           res = gfc_trans_read (code);
 663           break;
 664
 665         case EXEC_WRITE:
 666           res = gfc_trans_write (code);
 667           break;
 668
 669         case EXEC_IOLENGTH:
 670           res = gfc_trans_iolength (code);
 671           break;
 672
 673         case EXEC_BACKSPACE:
 674           res = gfc_trans_backspace (code);
 675           break;
 676
 677         case EXEC_ENDFILE:
 678           res = gfc_trans_endfile (code);
 679           break;
 680
 681         case EXEC_INQUIRE:
 682           res = gfc_trans_inquire (code);
 683           break;
 684
 685         case EXEC_REWIND:
 686           res = gfc_trans_rewind (code);
 687           break;
 688
 689         case EXEC_TRANSFER:
 690           res = gfc_trans_transfer (code);
 691           break;
 692
 693         case EXEC_DT_END:
 694           res = gfc_trans_dt_end (code);
 695           break;
 696
 697         case EXEC_OMP_ATOMIC:
 698         case EXEC_OMP_BARRIER:
 699         case EXEC_OMP_CRITICAL:
 700         case EXEC_OMP_DO:
 701         case EXEC_OMP_FLUSH:
 702         case EXEC_OMP_MASTER:
 703         case EXEC_OMP_ORDERED:
 704         case EXEC_OMP_PARALLEL:
 705         case EXEC_OMP_PARALLEL_DO:
 706         case EXEC_OMP_PARALLEL_SECTIONS:
 707         case EXEC_OMP_PARALLEL_WORKSHARE:
 708         case EXEC_OMP_SECTIONS:
 709         case EXEC_OMP_SINGLE:
 710         case EXEC_OMP_WORKSHARE:
 711           res = gfc_trans_omp_directive (code);
 712           break;
 713
 714         default:
 715           internal_error ("gfc_trans_code(): Bad statement code");
 716         }
 717
 718       gfc_set_backend_locus (&code->loc);
 719
 720       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 721         {
 722           if (TREE_CODE (res) == STATEMENT_LIST)
 723             annotate_all_with_locus (&res, input_location);
 724           else
 725             SET_EXPR_LOCATION (res, input_location);
 726
 727           /* Add the new statement to the block.  */
 728           gfc_add_expr_to_block (&block, res);
 729         }
 730     }
 731
 732   /* Return the finished block.  */
 733   return gfc_finish_block (&block);
 734 }
 735
 736
 737 /* This function is called after a complete program unit has been parsed
 738    and resolved.  */
 739
 740 void
 741 gfc_generate_code (gfc_namespace * ns)
 742 {
 743   if (ns->is_block_data)
 744     {
 745       gfc_generate_block_data (ns);
 746       return;
 747     }
 748
 749   gfc_generate_function_code (ns);
 750 }
 751
 752
 753 /* This function is called after a complete module has been parsed
 754    and resolved.  */
 755
 756 void
 757 gfc_generate_module_code (gfc_namespace * ns)
 758 {
 759   gfc_namespace *n;
 760
 761   gfc_generate_module_vars (ns);
 762
 763   /* We need to generate all module function prototypes first, to allow
 764      sibling calls.  */
 765   for (n = ns->contained; n; n = n->sibling)
 766     {
 767       if (!n->proc_name)
 768         continue;
 769
 770       gfc_create_function_decl (n);
 771     }
 772
 773   for (n = ns->contained; n; n = n->sibling)
 774     {
 775       if (!n->proc_name)
 776         continue;
 777
 778       gfc_generate_function_code (n);
 779     }
 780 }
 781