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       gfc_set_backend_locus (&code->loc);
 483
 484       if (code->here != 0)
 485         {
 486           res = gfc_trans_label_here (code);
 487           gfc_add_expr_to_block (&block, res);
 488         }
 489
 490       switch (code->op)
 491         {
 492         case EXEC_NOP:
 493           res = NULL_TREE;
 494           break;
 495
 496         case EXEC_ASSIGN:
 497           res = gfc_trans_assign (code);
 498           break;
 499
 500         case EXEC_LABEL_ASSIGN:
 501           res = gfc_trans_label_assign (code);
 502           break;
 503
 504         case EXEC_POINTER_ASSIGN:
 505           res = gfc_trans_pointer_assign (code);
 506           break;
 507
 508         case EXEC_CONTINUE:
 509           res = NULL_TREE;
 510           break;
 511
 512         case EXEC_CYCLE:
 513           res = gfc_trans_cycle (code);
 514           break;
 515
 516         case EXEC_EXIT:
 517           res = gfc_trans_exit (code);
 518           break;
 519
 520         case EXEC_GOTO:
 521           res = gfc_trans_goto (code);
 522           break;
 523
 524         case EXEC_ENTRY:
 525           res = gfc_trans_entry (code);
 526           break;
 527
 528         case EXEC_PAUSE:
 529           res = gfc_trans_pause (code);
 530           break;
 531
 532         case EXEC_STOP:
 533           res = gfc_trans_stop (code);
 534           break;
 535
 536         case EXEC_CALL:
 537           res = gfc_trans_call (code);
 538           break;
 539
 540         case EXEC_RETURN:
 541           res = gfc_trans_return (code);
 542           break;
 543
 544         case EXEC_IF:
 545           res = gfc_trans_if (code);
 546           break;
 547
 548         case EXEC_ARITHMETIC_IF:
 549           res = gfc_trans_arithmetic_if (code);
 550           break;
 551
 552         case EXEC_DO:
 553           res = gfc_trans_do (code);
 554           break;
 555
 556         case EXEC_DO_WHILE:
 557           res = gfc_trans_do_while (code);
 558           break;
 559
 560         case EXEC_SELECT:
 561           res = gfc_trans_select (code);
 562           break;
 563
 564         case EXEC_FORALL:
 565           res = gfc_trans_forall (code);
 566           break;
 567
 568         case EXEC_WHERE:
 569           res = gfc_trans_where (code);
 570           break;
 571
 572         case EXEC_ALLOCATE:
 573           res = gfc_trans_allocate (code);
 574           break;
 575
 576         case EXEC_DEALLOCATE:
 577           res = gfc_trans_deallocate (code);
 578           break;
 579
 580         case EXEC_OPEN:
 581           res = gfc_trans_open (code);
 582           break;
 583
 584         case EXEC_CLOSE:
 585           res = gfc_trans_close (code);
 586           break;
 587
 588         case EXEC_READ:
 589           res = gfc_trans_read (code);
 590           break;
 591
 592         case EXEC_WRITE:
 593           res = gfc_trans_write (code);
 594           break;
 595
 596         case EXEC_IOLENGTH:
 597           res = gfc_trans_iolength (code);
 598           break;
 599
 600         case EXEC_BACKSPACE:
 601           res = gfc_trans_backspace (code);
 602           break;
 603
 604         case EXEC_ENDFILE:
 605           res = gfc_trans_endfile (code);
 606           break;
 607
 608         case EXEC_INQUIRE:
 609           res = gfc_trans_inquire (code);
 610           break;
 611
 612         case EXEC_REWIND:
 613           res = gfc_trans_rewind (code);
 614           break;
 615
 616         case EXEC_TRANSFER:
 617           res = gfc_trans_transfer (code);
 618           break;
 619
 620         case EXEC_DT_END:
 621           res = gfc_trans_dt_end (code);
 622           break;
 623
 624         default:
 625           internal_error ("gfc_trans_code(): Bad statement code");
 626         }
 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 statemment 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