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