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, 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 "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 INDIRECT_REF with its natural type.  */
 286
 287 tree
 288 gfc_build_indirect_ref (tree t)
 289 {
 290   tree type = TREE_TYPE (t);
 291   gcc_assert (POINTER_TYPE_P (type));
 292   type = TREE_TYPE (type);
 293
 294   if (TREE_CODE (t) == ADDR_EXPR)
 295     return TREE_OPERAND (t, 0);
 296   else
 297     return build1 (INDIRECT_REF, type, t);
 298 }
 299
 300
 301 /* Build an ARRAY_REF with its natural type.  */
 302
 303 tree
 304 gfc_build_array_ref (tree base, tree offset)
 305 {
 306   tree type = TREE_TYPE (base);
 307   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 308   type = TREE_TYPE (type);
 309
 310   if (DECL_P (base))
 311     TREE_ADDRESSABLE (base) = 1;
 312
 313   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 314 }
 315
 316
 317 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
 318    build a CALL_EXPR.  */
 319
 320 tree
 321 gfc_build_function_call (tree fndecl, tree arglist)
 322 {
 323   tree fn;
 324   tree call;
 325
 326   fn = gfc_build_addr_expr (NULL, fndecl);
 327   call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)),
 328                  fn, arglist, NULL);
 329   TREE_SIDE_EFFECTS (call) = 1;
 330
 331   return call;
 332 }
 333
 334
 335 /* Generate a runtime error if COND is true.  */
 336
 337 void
 338 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
 339 {
 340   stmtblock_t block;
 341   tree body;
 342   tree tmp;
 343   tree args;
 344
 345   cond = fold (cond);
 346
 347   if (integer_zerop (cond))
 348     return;
 349
 350   /* The code to generate the error.  */
 351   gfc_start_block (&block);
 352
 353   gcc_assert (TREE_CODE (msg) == STRING_CST);
 354
 355   TREE_USED (msg) = 1;
 356
 357   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 358   args = gfc_chainon_list (NULL_TREE, tmp);
 359
 360   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 361   args = gfc_chainon_list (args, tmp);
 362
 363   tmp = build_int_cst (NULL_TREE, input_line);
 364   args = gfc_chainon_list (args, tmp);
 365
 366   tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
 367   gfc_add_expr_to_block (&block, tmp);
 368
 369   body = gfc_finish_block (&block);
 370
 371   if (integer_onep (cond))
 372     {
 373       gfc_add_expr_to_block (pblock, body);
 374     }
 375   else
 376     {
 377       /* Tell the compiler that this isn't likely.  */
 378       tmp = gfc_chainon_list (NULL_TREE, cond);
 379       tmp = gfc_chainon_list (tmp, integer_zero_node);
 380       cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
 381
 382       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 383       gfc_add_expr_to_block (pblock, tmp);
 384     }
 385 }
 386
 387
 388 /* Add a statement to a block.  */
 389
 390 void
 391 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 392 {
 393   gcc_assert (block);
 394
 395   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 396     return;
 397
 398   if (TREE_CODE (expr) != STATEMENT_LIST)
 399     expr = fold (expr);
 400
 401   if (block->head)
 402     {
 403       if (TREE_CODE (block->head) != STATEMENT_LIST)
 404         {
 405           tree tmp;
 406
 407           tmp = block->head;
 408           block->head = NULL_TREE;
 409           append_to_statement_list (tmp, &block->head);
 410         }
 411       append_to_statement_list (expr, &block->head);
 412     }
 413   else
 414     /* Don't bother creating a list if we only have a single statement.  */
 415     block->head = expr;
 416 }
 417
 418
 419 /* Add a block the end of a block.  */
 420
 421 void
 422 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 423 {
 424   gcc_assert (append);
 425   gcc_assert (!append->has_scope);
 426
 427   gfc_add_expr_to_block (block, append->head);
 428   append->head = NULL_TREE;
 429 }
 430
 431
 432 /* Get the current locus.  The structure may not be complete, and should
 433    only be used with gfc_set_backend_locus.  */
 434
 435 void
 436 gfc_get_backend_locus (locus * loc)
 437 {
 438   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 439 #ifdef USE_MAPPED_LOCATION
 440   loc->lb->location = input_location; /* FIXME adjust?? */
 441 #else
 442   loc->lb->linenum = input_line - 1;
 443 #endif
 444   loc->lb->file = gfc_current_backend_file;
 445 }
 446
 447
 448 /* Set the current locus.  */
 449
 450 void
 451 gfc_set_backend_locus (locus * loc)
 452 {
 453   gfc_current_backend_file = loc->lb->file;
 454 #ifdef USE_MAPPED_LOCATION
 455   input_location = loc->lb->location;
 456 #else
 457   input_line = loc->lb->linenum;
 458   input_filename = loc->lb->file->filename;
 459 #endif
 460 }
 461
 462
 463 /* Translate an executable statement.  */
 464
 465 tree
 466 gfc_trans_code (gfc_code * code)
 467 {
 468   stmtblock_t block;
 469   tree res;
 470
 471   if (!code)
 472     return build_empty_stmt ();
 473
 474   gfc_start_block (&block);
 475
 476   /* Translate statements one by one to GIMPLE trees until we reach
 477      the end of this gfc_code branch.  */
 478   for (; code; code = code->next)
 479     {
 480       if (code->here != 0)
 481         {
 482           res = gfc_trans_label_here (code);
 483           gfc_add_expr_to_block (&block, res);
 484         }
 485
 486       switch (code->op)
 487         {
 488         case EXEC_NOP:
 489           res = NULL_TREE;
 490           break;
 491
 492         case EXEC_ASSIGN:
 493           res = gfc_trans_assign (code);
 494           break;
 495
 496         case EXEC_LABEL_ASSIGN:
 497           res = gfc_trans_label_assign (code);
 498           break;
 499
 500         case EXEC_POINTER_ASSIGN:
 501           res = gfc_trans_pointer_assign (code);
 502           break;
 503
 504         case EXEC_CONTINUE:
 505           res = NULL_TREE;
 506           break;
 507
 508         case EXEC_CYCLE:
 509           res = gfc_trans_cycle (code);
 510           break;
 511
 512         case EXEC_EXIT:
 513           res = gfc_trans_exit (code);
 514           break;
 515
 516         case EXEC_GOTO:
 517           res = gfc_trans_goto (code);
 518           break;
 519
 520         case EXEC_ENTRY:
 521           res = gfc_trans_entry (code);
 522           break;
 523
 524         case EXEC_PAUSE:
 525           res = gfc_trans_pause (code);
 526           break;
 527
 528         case EXEC_STOP:
 529           res = gfc_trans_stop (code);
 530           break;
 531
 532         case EXEC_CALL:
 533           res = gfc_trans_call (code);
 534           break;
 535
 536         case EXEC_RETURN:
 537           res = gfc_trans_return (code);
 538           break;
 539
 540         case EXEC_IF:
 541           res = gfc_trans_if (code);
 542           break;
 543
 544         case EXEC_ARITHMETIC_IF:
 545           res = gfc_trans_arithmetic_if (code);
 546           break;
 547
 548         case EXEC_DO:
 549           res = gfc_trans_do (code);
 550           break;
 551
 552         case EXEC_DO_WHILE:
 553           res = gfc_trans_do_while (code);
 554           break;
 555
 556         case EXEC_SELECT:
 557           res = gfc_trans_select (code);
 558           break;
 559
 560         case EXEC_FORALL:
 561           res = gfc_trans_forall (code);
 562           break;
 563
 564         case EXEC_WHERE:
 565           res = gfc_trans_where (code);
 566           break;
 567
 568         case EXEC_ALLOCATE:
 569           res = gfc_trans_allocate (code);
 570           break;
 571
 572         case EXEC_DEALLOCATE:
 573           res = gfc_trans_deallocate (code);
 574           break;
 575
 576         case EXEC_OPEN:
 577           res = gfc_trans_open (code);
 578           break;
 579
 580         case EXEC_CLOSE:
 581           res = gfc_trans_close (code);
 582           break;
 583
 584         case EXEC_READ:
 585           res = gfc_trans_read (code);
 586           break;
 587
 588         case EXEC_WRITE:
 589           res = gfc_trans_write (code);
 590           break;
 591
 592         case EXEC_IOLENGTH:
 593           res = gfc_trans_iolength (code);
 594           break;
 595
 596         case EXEC_BACKSPACE:
 597           res = gfc_trans_backspace (code);
 598           break;
 599
 600         case EXEC_ENDFILE:
 601           res = gfc_trans_endfile (code);
 602           break;
 603
 604         case EXEC_INQUIRE:
 605           res = gfc_trans_inquire (code);
 606           break;
 607
 608         case EXEC_REWIND:
 609           res = gfc_trans_rewind (code);
 610           break;
 611
 612         case EXEC_TRANSFER:
 613           res = gfc_trans_transfer (code);
 614           break;
 615
 616         case EXEC_DT_END:
 617           res = gfc_trans_dt_end (code);
 618           break;
 619
 620         default:
 621           internal_error ("gfc_trans_code(): Bad statement code");
 622         }
 623
 624       gfc_set_backend_locus (&code->loc);
 625
 626       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 627         {
 628           if (TREE_CODE (res) == STATEMENT_LIST)
 629             annotate_all_with_locus (&res, input_location);
 630           else
 631             SET_EXPR_LOCATION (res, input_location);
 632
 633           /* Add the new statement to the block.  */
 634           gfc_add_expr_to_block (&block, res);
 635         }
 636     }
 637
 638   /* Return the finished block.  */
 639   return gfc_finish_block (&block);
 640 }
 641
 642
 643 /* This function is called after a complete program unit has been parsed
 644    and resolved.  */
 645
 646 void
 647 gfc_generate_code (gfc_namespace * ns)
 648 {
 649   gfc_symbol *main_program = NULL;
 650   symbol_attribute attr;
 651
 652   if (ns->is_block_data)
 653     {
 654       gfc_generate_block_data (ns);
 655       return;
 656     }
 657
 658   /* Main program subroutine.  */
 659   if (!ns->proc_name)
 660     {
 661       /* Lots of things get upset if a subroutine doesn't have a symbol, so we
 662          make one now.  Hopefully we've set all the required fields.  */
 663       gfc_get_symbol ("MAIN__", ns, &main_program);
 664       gfc_clear_attr (&attr);
 665       attr.flavor = FL_PROCEDURE;
 666       attr.proc = PROC_UNKNOWN;
 667       attr.subroutine = 1;
 668       attr.access = ACCESS_PUBLIC;
 669       main_program->attr = attr;
 670       /* Set the location to the first line of code.  */
 671       if (ns->code)
 672         main_program->declared_at = ns->code->loc;
 673       ns->proc_name = main_program;
 674       gfc_commit_symbols ();
 675     }
 676
 677   gfc_generate_function_code (ns);
 678 }
 679
 680
 681 /* This function is called after a complete module has been parsed
 682    and resolved.  */
 683
 684 void
 685 gfc_generate_module_code (gfc_namespace * ns)
 686 {
 687   gfc_namespace *n;
 688
 689   gfc_generate_module_vars (ns);
 690
 691   /* We need to generate all module function prototypes first, to allow
 692      sibling calls.  */
 693   for (n = ns->contained; n; n = n->sibling)
 694     {
 695       if (!n->proc_name)
 696         continue;
 697
 698       gfc_create_function_decl (n);
 699     }
 700
 701   for (n = ns->contained; n; n = n->sibling)
 702     {
 703       if (!n->proc_name)
 704         continue;
 705
 706       gfc_generate_function_code (n);
 707     }
 708 }
 709