gcc/fortran/trans.c

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