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   if (integer_zerop (cond))
 312     return;
 313
 314   /* The code to generate the error.  */
 315   gfc_start_block (&block);
 316
 317   gcc_assert (TREE_CODE (msg) == STRING_CST);
 318
 319   TREE_USED (msg) = 1;
 320
 321   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 322   args = gfc_chainon_list (NULL_TREE, tmp);
 323
 324   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 325   args = gfc_chainon_list (args, tmp);
 326
 327   tmp = build_int_cst (NULL_TREE, input_line);
 328   args = gfc_chainon_list (args, tmp);
 329
 330   tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
 331   gfc_add_expr_to_block (&block, tmp);
 332
 333   body = gfc_finish_block (&block);
 334
 335   if (integer_onep (cond))
 336     {
 337       gfc_add_expr_to_block (pblock, body);
 338     }
 339   else
 340     {
 341       /* Tell the compiler that this isn't likely.  */
 342       tmp = gfc_chainon_list (NULL_TREE, cond);
 343       tmp = gfc_chainon_list (tmp, integer_zero_node);
 344       cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
 345
 346       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 347       gfc_add_expr_to_block (pblock, tmp);
 348     }
 349 }
 350
 351
 352 /* Add a statement to a block.  */
 353
 354 void
 355 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 356 {
 357   gcc_assert (block);
 358
 359   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 360     return;
 361
 362   if (block->head)
 363     {
 364       if (TREE_CODE (block->head) != STATEMENT_LIST)
 365         {
 366           tree tmp;
 367
 368           tmp = block->head;
 369           block->head = NULL_TREE;
 370           append_to_statement_list (tmp, &block->head);
 371         }
 372       append_to_statement_list (expr, &block->head);
 373     }
 374   else
 375     /* Don't bother creating a list if we only have a single statement.  */
 376     block->head = expr;
 377 }
 378
 379
 380 /* Add a block the end of a block.  */
 381
 382 void
 383 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 384 {
 385   gcc_assert (append);
 386   gcc_assert (!append->has_scope);
 387
 388   gfc_add_expr_to_block (block, append->head);
 389   append->head = NULL_TREE;
 390 }
 391
 392
 393 /* Get the current locus.  The structure may not be complete, and should
 394    only be used with gfc_set_backend_locus.  */
 395
 396 void
 397 gfc_get_backend_locus (locus * loc)
 398 {
 399   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 400 #ifdef USE_MAPPED_LOCATION
 401   loc->lb->location = input_location;
 402 #else
 403   loc->lb->linenum = input_line;
 404 #endif
 405   loc->lb->file = gfc_current_backend_file;
 406 }
 407
 408
 409 /* Set the current locus.  */
 410
 411 void
 412 gfc_set_backend_locus (locus * loc)
 413 {
 414   gfc_current_backend_file = loc->lb->file;
 415 #ifdef USE_MAPPED_LOCATION
 416   input_location = loc->lb->location;
 417 #else
 418   input_line = loc->lb->linenum;
 419   input_filename = loc->lb->file->filename;
 420 #endif
 421 }
 422
 423
 424 /* Translate an executable statement.  */
 425
 426 tree
 427 gfc_trans_code (gfc_code * code)
 428 {
 429   stmtblock_t block;
 430   tree res;
 431
 432   if (!code)
 433     return build_empty_stmt ();
 434
 435   gfc_start_block (&block);
 436
 437   /* Translate statements one by one to GIMPLE trees until we reach
 438      the end of this gfc_code branch.  */
 439   for (; code; code = code->next)
 440     {
 441       if (code->here != 0)
 442         {
 443           res = gfc_trans_label_here (code);
 444           gfc_add_expr_to_block (&block, res);
 445         }
 446
 447       switch (code->op)
 448         {
 449         case EXEC_NOP:
 450           res = NULL_TREE;
 451           break;
 452
 453         case EXEC_ASSIGN:
 454           res = gfc_trans_assign (code);
 455           break;
 456
 457         case EXEC_LABEL_ASSIGN:
 458           res = gfc_trans_label_assign (code);
 459           break;
 460
 461         case EXEC_POINTER_ASSIGN:
 462           res = gfc_trans_pointer_assign (code);
 463           break;
 464
 465         case EXEC_CONTINUE:
 466           res = NULL_TREE;
 467           break;
 468
 469         case EXEC_CYCLE:
 470           res = gfc_trans_cycle (code);
 471           break;
 472
 473         case EXEC_EXIT:
 474           res = gfc_trans_exit (code);
 475           break;
 476
 477         case EXEC_GOTO:
 478           res = gfc_trans_goto (code);
 479           break;
 480
 481         case EXEC_ENTRY:
 482           res = gfc_trans_entry (code);
 483           break;
 484
 485         case EXEC_PAUSE:
 486           res = gfc_trans_pause (code);
 487           break;
 488
 489         case EXEC_STOP:
 490           res = gfc_trans_stop (code);
 491           break;
 492
 493         case EXEC_CALL:
 494           res = gfc_trans_call (code);
 495           break;
 496
 497         case EXEC_RETURN:
 498           res = gfc_trans_return (code);
 499           break;
 500
 501         case EXEC_IF:
 502           res = gfc_trans_if (code);
 503           break;
 504
 505         case EXEC_ARITHMETIC_IF:
 506           res = gfc_trans_arithmetic_if (code);
 507           break;
 508
 509         case EXEC_DO:
 510           res = gfc_trans_do (code);
 511           break;
 512
 513         case EXEC_DO_WHILE:
 514           res = gfc_trans_do_while (code);
 515           break;
 516
 517         case EXEC_SELECT:
 518           res = gfc_trans_select (code);
 519           break;
 520
 521         case EXEC_FLUSH:
 522           res = gfc_trans_flush (code);
 523           break;
 524
 525         case EXEC_FORALL:
 526           res = gfc_trans_forall (code);
 527           break;
 528
 529         case EXEC_WHERE:
 530           res = gfc_trans_where (code);
 531           break;
 532
 533         case EXEC_ALLOCATE:
 534           res = gfc_trans_allocate (code);
 535           break;
 536
 537         case EXEC_DEALLOCATE:
 538           res = gfc_trans_deallocate (code);
 539           break;
 540
 541         case EXEC_OPEN:
 542           res = gfc_trans_open (code);
 543           break;
 544
 545         case EXEC_CLOSE:
 546           res = gfc_trans_close (code);
 547           break;
 548
 549         case EXEC_READ:
 550           res = gfc_trans_read (code);
 551           break;
 552
 553         case EXEC_WRITE:
 554           res = gfc_trans_write (code);
 555           break;
 556
 557         case EXEC_IOLENGTH:
 558           res = gfc_trans_iolength (code);
 559           break;
 560
 561         case EXEC_BACKSPACE:
 562           res = gfc_trans_backspace (code);
 563           break;
 564
 565         case EXEC_ENDFILE:
 566           res = gfc_trans_endfile (code);
 567           break;
 568
 569         case EXEC_INQUIRE:
 570           res = gfc_trans_inquire (code);
 571           break;
 572
 573         case EXEC_REWIND:
 574           res = gfc_trans_rewind (code);
 575           break;
 576
 577         case EXEC_TRANSFER:
 578           res = gfc_trans_transfer (code);
 579           break;
 580
 581         case EXEC_DT_END:
 582           res = gfc_trans_dt_end (code);
 583           break;
 584
 585         default:
 586           internal_error ("gfc_trans_code(): Bad statement code");
 587         }
 588
 589       gfc_set_backend_locus (&code->loc);
 590
 591       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 592         {
 593           if (TREE_CODE (res) == STATEMENT_LIST)
 594             annotate_all_with_locus (&res, input_location);
 595           else
 596             SET_EXPR_LOCATION (res, input_location);
 597
 598           /* Add the new statement to the block.  */
 599           gfc_add_expr_to_block (&block, res);
 600         }
 601     }
 602
 603   /* Return the finished block.  */
 604   return gfc_finish_block (&block);
 605 }
 606
 607
 608 /* This function is called after a complete program unit has been parsed
 609    and resolved.  */
 610
 611 void
 612 gfc_generate_code (gfc_namespace * ns)
 613 {
 614   if (ns->is_block_data)
 615     {
 616       gfc_generate_block_data (ns);
 617       return;
 618     }
 619
 620   gfc_generate_function_code (ns);
 621 }
 622
 623
 624 /* This function is called after a complete module has been parsed
 625    and resolved.  */
 626
 627 void
 628 gfc_generate_module_code (gfc_namespace * ns)
 629 {
 630   gfc_namespace *n;
 631
 632   gfc_generate_module_vars (ns);
 633
 634   /* We need to generate all module function prototypes first, to allow
 635      sibling calls.  */
 636   for (n = ns->contained; n; n = n->sibling)
 637     {
 638       if (!n->proc_name)
 639         continue;
 640
 641       gfc_create_function_decl (n);
 642     }
 643
 644   for (n = ns->contained; n; n = n->sibling)
 645     {
 646       if (!n->proc_name)
 647         continue;
 648
 649       gfc_generate_function_code (n);
 650     }
 651 }
 652