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 = rationalize_compound_expr (stmtblock->head);
 219   stmtblock->head = NULL_TREE;
 220
 221   if (stmtblock->has_scope)
 222     {
 223       decl = getdecls ();
 224
 225       if (decl)
 226         {
 227           block = poplevel (1, 0, 0);
 228           expr = build_v (BIND_EXPR, decl, expr, block);
 229         }
 230       else
 231         poplevel (0, 0, 0);
 232     }
 233
 234   return expr;
 235 }
 236
 237
 238 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 239    natural type is used.  */
 240
 241 tree
 242 gfc_build_addr_expr (tree type, tree t)
 243 {
 244   tree base_type = TREE_TYPE (t);
 245   tree natural_type;
 246
 247   if (type && POINTER_TYPE_P (type)
 248       && TREE_CODE (base_type) == ARRAY_TYPE
 249       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 250          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 251     natural_type = type;
 252   else
 253     natural_type = build_pointer_type (base_type);
 254
 255   if (TREE_CODE (t) == INDIRECT_REF)
 256     {
 257       if (!type)
 258         type = natural_type;
 259       t = TREE_OPERAND (t, 0);
 260       natural_type = TREE_TYPE (t);
 261     }
 262   else
 263     {
 264       if (DECL_P (t))
 265         TREE_ADDRESSABLE (t) = 1;
 266       t = build1 (ADDR_EXPR, natural_type, t);
 267     }
 268
 269   if (type && natural_type != type)
 270     t = convert (type, t);
 271
 272   return t;
 273 }
 274
 275
 276 /* Build an INDIRECT_REF with its natural type.  */
 277
 278 tree
 279 gfc_build_indirect_ref (tree t)
 280 {
 281   tree type = TREE_TYPE (t);
 282   if (!POINTER_TYPE_P (type))
 283     abort ();
 284   type = TREE_TYPE (type);
 285
 286   if (TREE_CODE (t) == ADDR_EXPR)
 287     return TREE_OPERAND (t, 0);
 288   else
 289     return build1 (INDIRECT_REF, type, t);
 290 }
 291
 292
 293 /* Build an ARRAY_REF with its natural type.  */
 294
 295 tree
 296 gfc_build_array_ref (tree base, tree offset)
 297 {
 298   tree type = TREE_TYPE (base);
 299   if (TREE_CODE (type) != ARRAY_TYPE)
 300     abort ();
 301   type = TREE_TYPE (type);
 302
 303   if (DECL_P (base))
 304     TREE_ADDRESSABLE (base) = 1;
 305
 306   return build (ARRAY_REF, type, base, offset);
 307 }
 308
 309
 310 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
 311    build a CALL_EXPR.  */
 312
 313 tree
 314 gfc_build_function_call (tree fndecl, tree arglist)
 315 {
 316   tree fn;
 317   tree call;
 318
 319   fn = gfc_build_addr_expr (NULL, fndecl);
 320   call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL);
 321   TREE_SIDE_EFFECTS (call) = 1;
 322
 323   return call;
 324 }
 325
 326
 327 /* Generate a runtime error if COND is true.  */
 328
 329 void
 330 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
 331 {
 332   stmtblock_t block;
 333   tree body;
 334   tree tmp;
 335   tree args;
 336
 337   cond = fold (cond);
 338
 339   if (integer_zerop (cond))
 340     return;
 341
 342   /* The code to generate the error.  */
 343   gfc_start_block (&block);
 344
 345   assert (TREE_CODE (msg) == STRING_CST);
 346
 347   TREE_USED (msg) = 1;
 348
 349   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 350   args = gfc_chainon_list (NULL_TREE, tmp);
 351
 352   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 353   args = gfc_chainon_list (args, tmp);
 354
 355   tmp = build_int_2 (input_line, 0);
 356   args = gfc_chainon_list (args, tmp);
 357
 358   tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
 359   gfc_add_expr_to_block (&block, tmp);
 360
 361   body = gfc_finish_block (&block);
 362
 363   if (integer_onep (cond))
 364     {
 365       gfc_add_expr_to_block (pblock, body);
 366     }
 367   else
 368     {
 369       /* Tell the compiler that this isn't likley.  */
 370       tmp = gfc_chainon_list (NULL_TREE, cond);
 371       tmp = gfc_chainon_list (tmp, integer_zero_node);
 372       cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
 373
 374       tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ());
 375       gfc_add_expr_to_block (pblock, tmp);
 376     }
 377 }
 378
 379
 380 /* Add a statement to a bock.  */
 381
 382 void
 383 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 384 {
 385   assert (block);
 386
 387   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 388     return;
 389
 390   expr = fold (expr);
 391   if (block->head)
 392     block->head = build_v (COMPOUND_EXPR, block->head, expr);
 393   else
 394     block->head = expr;
 395 }
 396
 397
 398 /* Add a block the end of a block.  */
 399
 400 void
 401 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 402 {
 403   assert (append);
 404   assert (!append->has_scope);
 405
 406   gfc_add_expr_to_block (block, append->head);
 407   append->head = NULL_TREE;
 408 }
 409
 410
 411 /* Get the current locus.  The structure may not be complete, and should
 412    only be used with gfc_set_current_locus.  */
 413
 414 void
 415 gfc_get_backend_locus (locus * loc)
 416 {
 417   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 418   loc->lb->linenum = input_line - 1;
 419   loc->lb->file = gfc_current_backend_file;
 420 }
 421
 422
 423 /* Set the current locus.  */
 424
 425 void
 426 gfc_set_backend_locus (locus * loc)
 427 {
 428   input_line = loc->lb->linenum;
 429   gfc_current_backend_file = loc->lb->file;
 430   input_filename = loc->lb->file->filename;
 431 }
 432
 433
 434 /* Translate an executable statement.  */
 435
 436 tree
 437 gfc_trans_code (gfc_code * code)
 438 {
 439   stmtblock_t block;
 440   tree res;
 441
 442   if (!code)
 443     return build_empty_stmt ();
 444
 445   gfc_start_block (&block);
 446
 447   /* Translate statements one by one to GIMPLE trees until we reach
 448      the end of this gfc_code branch.  */
 449   for (; code; code = code->next)
 450     {
 451       gfc_set_backend_locus (&code->loc);
 452
 453       if (code->here != 0)
 454         {
 455           res = gfc_trans_label_here (code);
 456           gfc_add_expr_to_block (&block, res);
 457         }
 458
 459       switch (code->op)
 460         {
 461         case EXEC_NOP:
 462           res = NULL_TREE;
 463           break;
 464
 465         case EXEC_ASSIGN:
 466           res = gfc_trans_assign (code);
 467           break;
 468
 469         case EXEC_LABEL_ASSIGN:
 470           res = gfc_trans_label_assign (code);
 471           break;
 472
 473         case EXEC_POINTER_ASSIGN:
 474           res = gfc_trans_pointer_assign (code);
 475           break;
 476
 477         case EXEC_CONTINUE:
 478           res = NULL_TREE;
 479           break;
 480
 481         case EXEC_CYCLE:
 482           res = gfc_trans_cycle (code);
 483           break;
 484
 485         case EXEC_EXIT:
 486           res = gfc_trans_exit (code);
 487           break;
 488
 489         case EXEC_GOTO:
 490           res = gfc_trans_goto (code);
 491           break;
 492
 493         case EXEC_PAUSE:
 494           res = gfc_trans_pause (code);
 495           break;
 496
 497         case EXEC_STOP:
 498           res = gfc_trans_stop (code);
 499           break;
 500
 501         case EXEC_CALL:
 502           res = gfc_trans_call (code);
 503           break;
 504
 505         case EXEC_RETURN:
 506           res = gfc_trans_return (code);
 507           break;
 508
 509         case EXEC_IF:
 510           res = gfc_trans_if (code);
 511           break;
 512
 513         case EXEC_ARITHMETIC_IF:
 514           res = gfc_trans_arithmetic_if (code);
 515           break;
 516
 517         case EXEC_DO:
 518           res = gfc_trans_do (code);
 519           break;
 520
 521         case EXEC_DO_WHILE:
 522           res = gfc_trans_do_while (code);
 523           break;
 524
 525         case EXEC_SELECT:
 526           res = gfc_trans_select (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       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 594         {
 595           annotate_with_locus (res, input_location);
 596           /* Add the new statemment to the block.  */
 597           gfc_add_expr_to_block (&block, res);
 598         }
 599     }
 600
 601   /* Return the finished block.  */
 602   return gfc_finish_block (&block);
 603 }
 604
 605
 606 /* This function is called after a complete program unit has been parsed
 607    and resolved.  */
 608
 609 void
 610 gfc_generate_code (gfc_namespace * ns)
 611 {
 612   gfc_symbol *main_program = NULL;
 613   symbol_attribute attr;
 614
 615   /* Main program subroutine.  */
 616   if (!ns->proc_name)
 617     {
 618       /* Lots of things get upset if a subroutine doesn't have a symbol, so we
 619          make one now.  Hopefully we've set all the required fields.  */
 620       gfc_get_symbol ("MAIN__", ns, &main_program);
 621       gfc_clear_attr (&attr);
 622       attr.flavor = FL_PROCEDURE;
 623       attr.proc = PROC_UNKNOWN;
 624       attr.subroutine = 1;
 625       attr.access = ACCESS_PUBLIC;
 626       main_program->attr = attr;
 627       ns->proc_name = main_program;
 628       gfc_commit_symbols ();
 629     }
 630
 631   gfc_generate_function_code (ns);
 632 }
 633
 634
 635 /* This function is called after a complete module has been parsed
 636    and resolved.  */
 637
 638 void
 639 gfc_generate_module_code (gfc_namespace * ns)
 640 {
 641   gfc_namespace *n;
 642
 643   gfc_generate_module_vars (ns);
 644
 645   /* We need to generate all module function prototypes first, to allow
 646      sibling calls.  */
 647   for (n = ns->contained; n; n = n->sibling)
 648     {
 649       if (!n->proc_name)
 650         continue;
 651
 652       gfc_build_function_decl (n->proc_name);
 653     }
 654
 655   for (n = ns->contained; n; n = n->sibling)
 656     {
 657       if (!n->proc_name)
 658         continue;
 659
 660       gfc_generate_function_code (n);
 661     }
 662 }
 663