gcc/fortran/trans.c

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