gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  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 "gfortran.h"
  32 #include "trans.h"
  33 #include "trans-stmt.h"
  34 #include "trans-array.h"
  35 #include "trans-types.h"
  36 #include "trans-const.h"
  37
  38 /* Naming convention for backend interface code:
  39
  40    gfc_trans_*  translate gfc_code into STMT trees.
  41
  42    gfc_conv_*   expression conversion
  43
  44    gfc_get_*    get a backend tree representation of a decl or type  */
  45
  46 static gfc_file *gfc_current_backend_file;
  47
  48
  49 /* Advance along TREE_CHAIN n times.  */
  50
  51 tree
  52 gfc_advance_chain (tree t, int n)
  53 {
  54   for (; n > 0; n--)
  55     {
  56       gcc_assert (t != NULL_TREE);
  57       t = TREE_CHAIN (t);
  58     }
  59   return t;
  60 }
  61
  62
  63 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  64
  65 tree
  66 gfc_chainon_list (tree list, tree add)
  67 {
  68   tree l;
  69
  70   l = tree_cons (NULL_TREE, add, NULL_TREE);
  71
  72   return chainon (list, l);
  73 }
  74
  75
  76 /* Strip off a legitimate source ending from the input
  77    string NAME of length LEN.  */
  78
  79 static inline void
  80 remove_suffix (char *name, int len)
  81 {
  82   int i;
  83
  84   for (i = 2; i < 8 && len > i; i++)
  85     {
  86       if (name[len - i] == '.')
  87         {
  88           name[len - i] = '\0';
  89           break;
  90         }
  91     }
  92 }
  93
  94
  95 /* Creates a variable declaration with a given TYPE.  */
  96
  97 tree
  98 gfc_create_var_np (tree type, const char *prefix)
  99 {
 100   return create_tmp_var_raw (type, prefix);
 101 }
 102
 103
 104 /* Like above, but also adds it to the current scope.  */
 105
 106 tree
 107 gfc_create_var (tree type, const char *prefix)
 108 {
 109   tree tmp;
 110
 111   tmp = gfc_create_var_np (type, prefix);
 112
 113   pushdecl (tmp);
 114
 115   return tmp;
 116 }
 117
 118
 119 /* If the an expression is not constant, evaluate it now.  We assign the
 120    result of the expression to an artificially created variable VAR, and
 121    return a pointer to the VAR_DECL node for this variable.  */
 122
 123 tree
 124 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 125 {
 126   tree var;
 127
 128   if (CONSTANT_CLASS_P (expr))
 129     return expr;
 130
 131   var = gfc_create_var (TREE_TYPE (expr), NULL);
 132   gfc_add_modify_expr (pblock, var, expr);
 133
 134   return var;
 135 }
 136
 137
 138 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 139    A MODIFY_EXPR is an assignment: LHS <- RHS.  */
 140
 141 void
 142 gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
 143 {
 144   tree tmp;
 145
 146 #ifdef ENABLE_CHECKING
 147   /* Make sure that the types of the rhs and the lhs are the same
 148      for scalar assignments.  We should probably have something
 149      similar for aggregates, but right now removing that check just
 150      breaks everything.  */
 151   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
 152               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 153 #endif
 154
 155   tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
 156   gfc_add_expr_to_block (pblock, tmp);
 157 }
 158
 159
 160 /* Create a new scope/binding level and initialize a block.  Care must be
 161    taken when translating expressions as any temporaries will be placed in
 162    the innermost scope.  */
 163
 164 void
 165 gfc_start_block (stmtblock_t * block)
 166 {
 167   /* Start a new binding level.  */
 168   pushlevel (0);
 169   block->has_scope = 1;
 170
 171   /* The block is empty.  */
 172   block->head = NULL_TREE;
 173 }
 174
 175
 176 /* Initialize a block without creating a new scope.  */
 177
 178 void
 179 gfc_init_block (stmtblock_t * block)
 180 {
 181   block->head = NULL_TREE;
 182   block->has_scope = 0;
 183 }
 184
 185
 186 /* Sometimes we create a scope but it turns out that we don't actually
 187    need it.  This function merges the scope of BLOCK with its parent.
 188    Only variable decls will be merged, you still need to add the code.  */
 189
 190 void
 191 gfc_merge_block_scope (stmtblock_t * block)
 192 {
 193   tree decl;
 194   tree next;
 195
 196   gcc_assert (block->has_scope);
 197   block->has_scope = 0;
 198
 199   /* Remember the decls in this scope.  */
 200   decl = getdecls ();
 201   poplevel (0, 0, 0);
 202
 203   /* Add them to the parent scope.  */
 204   while (decl != NULL_TREE)
 205     {
 206       next = TREE_CHAIN (decl);
 207       TREE_CHAIN (decl) = NULL_TREE;
 208
 209       pushdecl (decl);
 210       decl = next;
 211     }
 212 }
 213
 214
 215 /* Finish a scope containing a block of statements.  */
 216
 217 tree
 218 gfc_finish_block (stmtblock_t * stmtblock)
 219 {
 220   tree decl;
 221   tree expr;
 222   tree block;
 223
 224   expr = stmtblock->head;
 225   if (!expr)
 226     expr = build_empty_stmt ();
 227
 228   stmtblock->head = NULL_TREE;
 229
 230   if (stmtblock->has_scope)
 231     {
 232       decl = getdecls ();
 233
 234       if (decl)
 235         {
 236           block = poplevel (1, 0, 0);
 237           expr = build3_v (BIND_EXPR, decl, expr, block);
 238         }
 239       else
 240         poplevel (0, 0, 0);
 241     }
 242
 243   return expr;
 244 }
 245
 246
 247 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 248    natural type is used.  */
 249
 250 tree
 251 gfc_build_addr_expr (tree type, tree t)
 252 {
 253   tree base_type = TREE_TYPE (t);
 254   tree natural_type;
 255
 256   if (type && POINTER_TYPE_P (type)
 257       && TREE_CODE (base_type) == ARRAY_TYPE
 258       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 259          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 260     natural_type = type;
 261   else
 262     natural_type = build_pointer_type (base_type);
 263
 264   if (TREE_CODE (t) == INDIRECT_REF)
 265     {
 266       if (!type)
 267         type = natural_type;
 268       t = TREE_OPERAND (t, 0);
 269       natural_type = TREE_TYPE (t);
 270     }
 271   else
 272     {
 273       if (DECL_P (t))
 274         TREE_ADDRESSABLE (t) = 1;
 275       t = build1 (ADDR_EXPR, natural_type, t);
 276     }
 277
 278   if (type && natural_type != type)
 279     t = convert (type, t);
 280
 281   return t;
 282 }
 283
 284
 285 /* Build an ARRAY_REF with its natural type.  */
 286
 287 tree
 288 gfc_build_array_ref (tree base, tree offset)
 289 {
 290   tree type = TREE_TYPE (base);
 291   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 292   type = TREE_TYPE (type);
 293
 294   if (DECL_P (base))
 295     TREE_ADDRESSABLE (base) = 1;
 296
 297   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 298 }
 299
 300
 301 /* Generate a runtime error if COND is true.  */
 302
 303 void
 304 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
 305 {
 306   stmtblock_t block;
 307   tree body;
 308   tree tmp;
 309   tree args;
 310
 311   if (integer_zerop (cond))
 312     return;
 313
 314   /* The code to generate the error.  */
 315   gfc_start_block (&block);
 316
 317   gcc_assert (TREE_CODE (msg) == STRING_CST);
 318
 319   TREE_USED (msg) = 1;
 320
 321   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 322   args = gfc_chainon_list (NULL_TREE, tmp);
 323
 324   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 325   args = gfc_chainon_list (args, tmp);
 326
 327   tmp = build_int_cst (NULL_TREE, input_line);
 328   args = gfc_chainon_list (args, tmp);
 329
 330   tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
 331   gfc_add_expr_to_block (&block, tmp);
 332
 333   body = gfc_finish_block (&block);
 334
 335   if (integer_onep (cond))
 336     {
 337       gfc_add_expr_to_block (pblock, body);
 338     }
 339   else
 340     {
 341       /* Tell the compiler that this isn't likely.  */
 342       tmp = gfc_chainon_list (NULL_TREE, cond);
 343       tmp = gfc_chainon_list (tmp, integer_zero_node);
 344       cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
 345
 346       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 347       gfc_add_expr_to_block (pblock, tmp);
 348     }
 349 }
 350
 351
 352 /* Add a statement to a block.  */
 353
 354 void
 355 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 356 {
 357   gcc_assert (block);
 358
 359   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 360     return;
 361
 362   if (TREE_CODE (expr) != STATEMENT_LIST
 363       && TREE_CODE_CLASS (TREE_CODE (expr)) != tcc_statement)
 364     expr = fold (expr);
 365
 366   if (block->head)
 367     {
 368       if (TREE_CODE (block->head) != STATEMENT_LIST)
 369         {
 370           tree tmp;
 371
 372           tmp = block->head;
 373           block->head = NULL_TREE;
 374           append_to_statement_list (tmp, &block->head);
 375         }
 376       append_to_statement_list (expr, &block->head);
 377     }
 378   else
 379     /* Don't bother creating a list if we only have a single statement.  */
 380     block->head = expr;
 381 }
 382
 383
 384 /* Add a block the end of a block.  */
 385
 386 void
 387 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 388 {
 389   gcc_assert (append);
 390   gcc_assert (!append->has_scope);
 391
 392   gfc_add_expr_to_block (block, append->head);
 393   append->head = NULL_TREE;
 394 }
 395
 396
 397 /* Get the current locus.  The structure may not be complete, and should
 398    only be used with gfc_set_backend_locus.  */
 399
 400 void
 401 gfc_get_backend_locus (locus * loc)
 402 {
 403   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 404 #ifdef USE_MAPPED_LOCATION
 405   loc->lb->location = input_location;
 406 #else
 407   loc->lb->linenum = input_line;
 408 #endif
 409   loc->lb->file = gfc_current_backend_file;
 410 }
 411
 412
 413 /* Set the current locus.  */
 414
 415 void
 416 gfc_set_backend_locus (locus * loc)
 417 {
 418   gfc_current_backend_file = loc->lb->file;
 419 #ifdef USE_MAPPED_LOCATION
 420   input_location = loc->lb->location;
 421 #else
 422   input_line = loc->lb->linenum;
 423   input_filename = loc->lb->file->filename;
 424 #endif
 425 }
 426
 427
 428 /* Translate an executable statement.  */
 429
 430 tree
 431 gfc_trans_code (gfc_code * code)
 432 {
 433   stmtblock_t block;
 434   tree res;
 435
 436   if (!code)
 437     return build_empty_stmt ();
 438
 439   gfc_start_block (&block);
 440
 441   /* Translate statements one by one to GIMPLE trees until we reach
 442      the end of this gfc_code branch.  */
 443   for (; code; code = code->next)
 444     {
 445       if (code->here != 0)
 446         {
 447           res = gfc_trans_label_here (code);
 448           gfc_add_expr_to_block (&block, res);
 449         }
 450
 451       switch (code->op)
 452         {
 453         case EXEC_NOP:
 454           res = NULL_TREE;
 455           break;
 456
 457         case EXEC_ASSIGN:
 458           res = gfc_trans_assign (code);
 459           break;
 460
 461         case EXEC_LABEL_ASSIGN:
 462           res = gfc_trans_label_assign (code);
 463           break;
 464
 465         case EXEC_POINTER_ASSIGN:
 466           res = gfc_trans_pointer_assign (code);
 467           break;
 468
 469         case EXEC_CONTINUE:
 470           res = NULL_TREE;
 471           break;
 472
 473         case EXEC_CYCLE:
 474           res = gfc_trans_cycle (code);
 475           break;
 476
 477         case EXEC_EXIT:
 478           res = gfc_trans_exit (code);
 479           break;
 480
 481         case EXEC_GOTO:
 482           res = gfc_trans_goto (code);
 483           break;
 484
 485         case EXEC_ENTRY:
 486           res = gfc_trans_entry (code);
 487           break;
 488
 489         case EXEC_PAUSE:
 490           res = gfc_trans_pause (code);
 491           break;
 492
 493         case EXEC_STOP:
 494           res = gfc_trans_stop (code);
 495           break;
 496
 497         case EXEC_CALL:
 498           res = gfc_trans_call (code);
 499           break;
 500
 501         case EXEC_RETURN:
 502           res = gfc_trans_return (code);
 503           break;
 504
 505         case EXEC_IF:
 506           res = gfc_trans_if (code);
 507           break;
 508
 509         case EXEC_ARITHMETIC_IF:
 510           res = gfc_trans_arithmetic_if (code);
 511           break;
 512
 513         case EXEC_DO:
 514           res = gfc_trans_do (code);
 515           break;
 516
 517         case EXEC_DO_WHILE:
 518           res = gfc_trans_do_while (code);
 519           break;
 520
 521         case EXEC_SELECT:
 522           res = gfc_trans_select (code);
 523           break;
 524
 525         case EXEC_FLUSH:
 526           res = gfc_trans_flush (code);
 527           break;
 528
 529         case EXEC_FORALL:
 530           res = gfc_trans_forall (code);
 531           break;
 532
 533         case EXEC_WHERE:
 534           res = gfc_trans_where (code);
 535           break;
 536
 537         case EXEC_ALLOCATE:
 538           res = gfc_trans_allocate (code);
 539           break;
 540
 541         case EXEC_DEALLOCATE:
 542           res = gfc_trans_deallocate (code);
 543           break;
 544
 545         case EXEC_OPEN:
 546           res = gfc_trans_open (code);
 547           break;
 548
 549         case EXEC_CLOSE:
 550           res = gfc_trans_close (code);
 551           break;
 552
 553         case EXEC_READ:
 554           res = gfc_trans_read (code);
 555           break;
 556
 557         case EXEC_WRITE:
 558           res = gfc_trans_write (code);
 559           break;
 560
 561         case EXEC_IOLENGTH:
 562           res = gfc_trans_iolength (code);
 563           break;
 564
 565         case EXEC_BACKSPACE:
 566           res = gfc_trans_backspace (code);
 567           break;
 568
 569         case EXEC_ENDFILE:
 570           res = gfc_trans_endfile (code);
 571           break;
 572
 573         case EXEC_INQUIRE:
 574           res = gfc_trans_inquire (code);
 575           break;
 576
 577         case EXEC_REWIND:
 578           res = gfc_trans_rewind (code);
 579           break;
 580
 581         case EXEC_TRANSFER:
 582           res = gfc_trans_transfer (code);
 583           break;
 584
 585         case EXEC_DT_END:
 586           res = gfc_trans_dt_end (code);
 587           break;
 588
 589         default:
 590           internal_error ("gfc_trans_code(): Bad statement code");
 591         }
 592
 593       gfc_set_backend_locus (&code->loc);
 594
 595       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 596         {
 597           if (TREE_CODE (res) == STATEMENT_LIST)
 598             annotate_all_with_locus (&res, input_location);
 599           else
 600             SET_EXPR_LOCATION (res, input_location);
 601
 602           /* Add the new statement to the block.  */
 603           gfc_add_expr_to_block (&block, res);
 604         }
 605     }
 606
 607   /* Return the finished block.  */
 608   return gfc_finish_block (&block);
 609 }
 610
 611
 612 /* This function is called after a complete program unit has been parsed
 613    and resolved.  */
 614
 615 void
 616 gfc_generate_code (gfc_namespace * ns)
 617 {
 618   if (ns->is_block_data)
 619     {
 620       gfc_generate_block_data (ns);
 621       return;
 622     }
 623
 624   gfc_generate_function_code (ns);
 625 }
 626
 627
 628 /* This function is called after a complete module has been parsed
 629    and resolved.  */
 630
 631 void
 632 gfc_generate_module_code (gfc_namespace * ns)
 633 {
 634   gfc_namespace *n;
 635
 636   gfc_generate_module_vars (ns);
 637
 638   /* We need to generate all module function prototypes first, to allow
 639      sibling calls.  */
 640   for (n = ns->contained; n; n = n->sibling)
 641     {
 642       if (!n->proc_name)
 643         continue;
 644
 645       gfc_create_function_decl (n);
 646     }
 647
 648   for (n = ns->contained; n; n = n->sibling)
 649     {
 650       if (!n->proc_name)
 651         continue;
 652
 653       gfc_generate_function_code (n);
 654     }
 655 }
 656