gcc/fortran/trans.c

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