gcc/fortran/trans.c

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