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 /* Given a function declaration FNDECL and an argument list ARGLIST,
 302    build a CALL_EXPR.  */
 303
 304 tree
 305 gfc_build_function_call (tree fndecl, tree arglist)
 306 {
 307   tree fn;
 308   tree call;
 309
 310   fn = gfc_build_addr_expr (NULL, fndecl);
 311   call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)),
 312                  fn, arglist, NULL);
 313   TREE_SIDE_EFFECTS (call) = 1;
 314
 315   return call;
 316 }
 317
 318
 319 /* Generate a runtime error if COND is true.  */
 320
 321 void
 322 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
 323 {
 324   stmtblock_t block;
 325   tree body;
 326   tree tmp;
 327   tree args;
 328
 329   cond = fold (cond);
 330
 331   if (integer_zerop (cond))
 332     return;
 333
 334   /* The code to generate the error.  */
 335   gfc_start_block (&block);
 336
 337   gcc_assert (TREE_CODE (msg) == STRING_CST);
 338
 339   TREE_USED (msg) = 1;
 340
 341   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 342   args = gfc_chainon_list (NULL_TREE, tmp);
 343
 344   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 345   args = gfc_chainon_list (args, tmp);
 346
 347   tmp = build_int_cst (NULL_TREE, input_line);
 348   args = gfc_chainon_list (args, tmp);
 349
 350   tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
 351   gfc_add_expr_to_block (&block, tmp);
 352
 353   body = gfc_finish_block (&block);
 354
 355   if (integer_onep (cond))
 356     {
 357       gfc_add_expr_to_block (pblock, body);
 358     }
 359   else
 360     {
 361       /* Tell the compiler that this isn't likely.  */
 362       tmp = gfc_chainon_list (NULL_TREE, cond);
 363       tmp = gfc_chainon_list (tmp, integer_zero_node);
 364       cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
 365
 366       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 367       gfc_add_expr_to_block (pblock, tmp);
 368     }
 369 }
 370
 371
 372 /* Add a statement to a block.  */
 373
 374 void
 375 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 376 {
 377   gcc_assert (block);
 378
 379   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 380     return;
 381
 382   if (TREE_CODE (expr) != STATEMENT_LIST)
 383     expr = fold (expr);
 384
 385   if (block->head)
 386     {
 387       if (TREE_CODE (block->head) != STATEMENT_LIST)
 388         {
 389           tree tmp;
 390
 391           tmp = block->head;
 392           block->head = NULL_TREE;
 393           append_to_statement_list (tmp, &block->head);
 394         }
 395       append_to_statement_list (expr, &block->head);
 396     }
 397   else
 398     /* Don't bother creating a list if we only have a single statement.  */
 399     block->head = expr;
 400 }
 401
 402
 403 /* Add a block the end of a block.  */
 404
 405 void
 406 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 407 {
 408   gcc_assert (append);
 409   gcc_assert (!append->has_scope);
 410
 411   gfc_add_expr_to_block (block, append->head);
 412   append->head = NULL_TREE;
 413 }
 414
 415
 416 /* Get the current locus.  The structure may not be complete, and should
 417    only be used with gfc_set_backend_locus.  */
 418
 419 void
 420 gfc_get_backend_locus (locus * loc)
 421 {
 422   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 423 #ifdef USE_MAPPED_LOCATION
 424   loc->lb->location = input_location;
 425 #else
 426   loc->lb->linenum = input_line;
 427 #endif
 428   loc->lb->file = gfc_current_backend_file;
 429 }
 430
 431
 432 /* Set the current locus.  */
 433
 434 void
 435 gfc_set_backend_locus (locus * loc)
 436 {
 437   gfc_current_backend_file = loc->lb->file;
 438 #ifdef USE_MAPPED_LOCATION
 439   input_location = loc->lb->location;
 440 #else
 441   input_line = loc->lb->linenum;
 442   input_filename = loc->lb->file->filename;
 443 #endif
 444 }
 445
 446
 447 /* Translate an executable statement.  */
 448
 449 tree
 450 gfc_trans_code (gfc_code * code)
 451 {
 452   stmtblock_t block;
 453   tree res;
 454
 455   if (!code)
 456     return build_empty_stmt ();
 457
 458   gfc_start_block (&block);
 459
 460   /* Translate statements one by one to GIMPLE trees until we reach
 461      the end of this gfc_code branch.  */
 462   for (; code; code = code->next)
 463     {
 464       if (code->here != 0)
 465         {
 466           res = gfc_trans_label_here (code);
 467           gfc_add_expr_to_block (&block, res);
 468         }
 469
 470       switch (code->op)
 471         {
 472         case EXEC_NOP:
 473           res = NULL_TREE;
 474           break;
 475
 476         case EXEC_ASSIGN:
 477           res = gfc_trans_assign (code);
 478           break;
 479
 480         case EXEC_LABEL_ASSIGN:
 481           res = gfc_trans_label_assign (code);
 482           break;
 483
 484         case EXEC_POINTER_ASSIGN:
 485           res = gfc_trans_pointer_assign (code);
 486           break;
 487
 488         case EXEC_CONTINUE:
 489           res = NULL_TREE;
 490           break;
 491
 492         case EXEC_CYCLE:
 493           res = gfc_trans_cycle (code);
 494           break;
 495
 496         case EXEC_EXIT:
 497           res = gfc_trans_exit (code);
 498           break;
 499
 500         case EXEC_GOTO:
 501           res = gfc_trans_goto (code);
 502           break;
 503
 504         case EXEC_ENTRY:
 505           res = gfc_trans_entry (code);
 506           break;
 507
 508         case EXEC_PAUSE:
 509           res = gfc_trans_pause (code);
 510           break;
 511
 512         case EXEC_STOP:
 513           res = gfc_trans_stop (code);
 514           break;
 515
 516         case EXEC_CALL:
 517           res = gfc_trans_call (code);
 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         default:
 609           internal_error ("gfc_trans_code(): Bad statement code");
 610         }
 611
 612       gfc_set_backend_locus (&code->loc);
 613
 614       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 615         {
 616           if (TREE_CODE (res) == STATEMENT_LIST)
 617             annotate_all_with_locus (&res, input_location);
 618           else
 619             SET_EXPR_LOCATION (res, input_location);
 620
 621           /* Add the new statement to the block.  */
 622           gfc_add_expr_to_block (&block, res);
 623         }
 624     }
 625
 626   /* Return the finished block.  */
 627   return gfc_finish_block (&block);
 628 }
 629
 630
 631 /* This function is called after a complete program unit has been parsed
 632    and resolved.  */
 633
 634 void
 635 gfc_generate_code (gfc_namespace * ns)
 636 {
 637   if (ns->is_block_data)
 638     {
 639       gfc_generate_block_data (ns);
 640       return;
 641     }
 642
 643   gfc_generate_function_code (ns);
 644 }
 645
 646
 647 /* This function is called after a complete module has been parsed
 648    and resolved.  */
 649
 650 void
 651 gfc_generate_module_code (gfc_namespace * ns)
 652 {
 653   gfc_namespace *n;
 654
 655   gfc_generate_module_vars (ns);
 656
 657   /* We need to generate all module function prototypes first, to allow
 658      sibling calls.  */
 659   for (n = ns->contained; n; n = n->sibling)
 660     {
 661       if (!n->proc_name)
 662         continue;
 663
 664       gfc_create_function_decl (n);
 665     }
 666
 667   for (n = ns->contained; n; n = n->sibling)
 668     {
 669       if (!n->proc_name)
 670         continue;
 671
 672       gfc_generate_function_code (n);
 673     }
 674 }
 675