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 #ifdef ENABLE_CHECKING
 150   /* Make sure that the types of the rhs and the lhs are the same
 151      for scalar assignments.  We should probably have something
 152      similar for aggregates, but right now removing that check just
 153      breaks everything.  */
 154   if (TREE_TYPE (rhs) != TREE_TYPE (lhs)
 155       && !AGGREGATE_TYPE_P (TREE_TYPE (lhs)))
 156     abort ();
 157 #endif
 158
 159   tmp = fold (build_v (MODIFY_EXPR, lhs, rhs));
 160   gfc_add_expr_to_block (pblock, tmp);
 161 }
 162
 163
 164 /* Create a new scope/binding level and initialize a block.  Care must be
 165    taken when translating expessions as any temporaries will be placed in
 166    the innermost scope.  */
 167
 168 void
 169 gfc_start_block (stmtblock_t * block)
 170 {
 171   /* Start a new binding level.  */
 172   pushlevel (0);
 173   block->has_scope = 1;
 174
 175   /* The block is empty.  */
 176   block->head = NULL_TREE;
 177 }
 178
 179
 180 /* Initialize a block without creating a new scope.  */
 181
 182 void
 183 gfc_init_block (stmtblock_t * block)
 184 {
 185   block->head = NULL_TREE;
 186   block->has_scope = 0;
 187 }
 188
 189
 190 /* Sometimes we create a scope but it turns out that we don't actually
 191    need it.  This function merges the scope of BLOCK with its parent.
 192    Only variable decls will be merged, you still need to add the code.  */
 193
 194 void
 195 gfc_merge_block_scope (stmtblock_t * block)
 196 {
 197   tree decl;
 198   tree next;
 199
 200   assert (block->has_scope);
 201   block->has_scope = 0;
 202
 203   /* Remember the decls in this scope.  */
 204   decl = getdecls ();
 205   poplevel (0, 0, 0);
 206
 207   /* Add them to the parent scope.  */
 208   while (decl != NULL_TREE)
 209     {
 210       next = TREE_CHAIN (decl);
 211       TREE_CHAIN (decl) = NULL_TREE;
 212
 213       pushdecl (decl);
 214       decl = next;
 215     }
 216 }
 217
 218
 219 /* Finish a scope containing a block of statements.  */
 220
 221 tree
 222 gfc_finish_block (stmtblock_t * stmtblock)
 223 {
 224   tree decl;
 225   tree expr;
 226   tree block;
 227
 228   expr = stmtblock->head;
 229   if (!expr)
 230     expr = build_empty_stmt ();
 231
 232   stmtblock->head = NULL_TREE;
 233
 234   if (stmtblock->has_scope)
 235     {
 236       decl = getdecls ();
 237
 238       if (decl)
 239         {
 240           block = poplevel (1, 0, 0);
 241           expr = build_v (BIND_EXPR, decl, expr, block);
 242         }
 243       else
 244         poplevel (0, 0, 0);
 245     }
 246
 247   return expr;
 248 }
 249
 250
 251 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 252    natural type is used.  */
 253
 254 tree
 255 gfc_build_addr_expr (tree type, tree t)
 256 {
 257   tree base_type = TREE_TYPE (t);
 258   tree natural_type;
 259
 260   if (type && POINTER_TYPE_P (type)
 261       && TREE_CODE (base_type) == ARRAY_TYPE
 262       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 263          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 264     natural_type = type;
 265   else
 266     natural_type = build_pointer_type (base_type);
 267
 268   if (TREE_CODE (t) == INDIRECT_REF)
 269     {
 270       if (!type)
 271         type = natural_type;
 272       t = TREE_OPERAND (t, 0);
 273       natural_type = TREE_TYPE (t);
 274     }
 275   else
 276     {
 277       if (DECL_P (t))
 278         TREE_ADDRESSABLE (t) = 1;
 279       t = build1 (ADDR_EXPR, natural_type, t);
 280     }
 281
 282   if (type && natural_type != type)
 283     t = convert (type, t);
 284
 285   return t;
 286 }
 287
 288
 289 /* Build an INDIRECT_REF with its natural type.  */
 290
 291 tree
 292 gfc_build_indirect_ref (tree t)
 293 {
 294   tree type = TREE_TYPE (t);
 295   if (!POINTER_TYPE_P (type))
 296     abort ();
 297   type = TREE_TYPE (type);
 298
 299   if (TREE_CODE (t) == ADDR_EXPR)
 300     return TREE_OPERAND (t, 0);
 301   else
 302     return build1 (INDIRECT_REF, type, t);
 303 }
 304
 305
 306 /* Build an ARRAY_REF with its natural type.  */
 307
 308 tree
 309 gfc_build_array_ref (tree base, tree offset)
 310 {
 311   tree type = TREE_TYPE (base);
 312   if (TREE_CODE (type) != ARRAY_TYPE)
 313     abort ();
 314   type = TREE_TYPE (type);
 315
 316   if (DECL_P (base))
 317     TREE_ADDRESSABLE (base) = 1;
 318
 319   return build (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 320 }
 321
 322
 323 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
 324    build a CALL_EXPR.  */
 325
 326 tree
 327 gfc_build_function_call (tree fndecl, tree arglist)
 328 {
 329   tree fn;
 330   tree call;
 331
 332   fn = gfc_build_addr_expr (NULL, fndecl);
 333   call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL);
 334   TREE_SIDE_EFFECTS (call) = 1;
 335
 336   return call;
 337 }
 338
 339
 340 /* Generate a runtime error if COND is true.  */
 341
 342 void
 343 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
 344 {
 345   stmtblock_t block;
 346   tree body;
 347   tree tmp;
 348   tree args;
 349
 350   cond = fold (cond);
 351
 352   if (integer_zerop (cond))
 353     return;
 354
 355   /* The code to generate the error.  */
 356   gfc_start_block (&block);
 357
 358   assert (TREE_CODE (msg) == STRING_CST);
 359
 360   TREE_USED (msg) = 1;
 361
 362   tmp = gfc_build_addr_expr (pchar_type_node, msg);
 363   args = gfc_chainon_list (NULL_TREE, tmp);
 364
 365   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
 366   args = gfc_chainon_list (args, tmp);
 367
 368   tmp = build_int_cst (NULL_TREE, input_line, 0);
 369   args = gfc_chainon_list (args, tmp);
 370
 371   tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
 372   gfc_add_expr_to_block (&block, tmp);
 373
 374   body = gfc_finish_block (&block);
 375
 376   if (integer_onep (cond))
 377     {
 378       gfc_add_expr_to_block (pblock, body);
 379     }
 380   else
 381     {
 382       /* Tell the compiler that this isn't likely.  */
 383       tmp = gfc_chainon_list (NULL_TREE, cond);
 384       tmp = gfc_chainon_list (tmp, integer_zero_node);
 385       cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
 386
 387       tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ());
 388       gfc_add_expr_to_block (pblock, tmp);
 389     }
 390 }
 391
 392
 393 /* Add a statement to a block.  */
 394
 395 void
 396 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 397 {
 398   assert (block);
 399
 400   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 401     return;
 402
 403   if (TREE_CODE (expr) != STATEMENT_LIST)
 404     expr = fold (expr);
 405
 406   if (block->head)
 407     {
 408       if (TREE_CODE (block->head) != STATEMENT_LIST)
 409         {
 410           tree tmp;
 411
 412           tmp = block->head;
 413           block->head = NULL_TREE;
 414           append_to_statement_list (tmp, &block->head);
 415         }
 416       append_to_statement_list (expr, &block->head);
 417     }
 418   else
 419     /* Don't bother creating a list if we only have a single statement.  */
 420     block->head = expr;
 421 }
 422
 423
 424 /* Add a block the end of a block.  */
 425
 426 void
 427 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 428 {
 429   assert (append);
 430   assert (!append->has_scope);
 431
 432   gfc_add_expr_to_block (block, append->head);
 433   append->head = NULL_TREE;
 434 }
 435
 436
 437 /* Get the current locus.  The structure may not be complete, and should
 438    only be used with gfc_set_backend_locus.  */
 439
 440 void
 441 gfc_get_backend_locus (locus * loc)
 442 {
 443   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 444   loc->lb->linenum = input_line - 1;
 445   loc->lb->file = gfc_current_backend_file;
 446 }
 447
 448
 449 /* Set the current locus.  */
 450
 451 void
 452 gfc_set_backend_locus (locus * loc)
 453 {
 454   input_line = loc->lb->linenum;
 455   gfc_current_backend_file = loc->lb->file;
 456   input_filename = loc->lb->file->filename;
 457 }
 458
 459
 460 /* Translate an executable statement.  */
 461
 462 tree
 463 gfc_trans_code (gfc_code * code)
 464 {
 465   stmtblock_t block;
 466   tree res;
 467
 468   if (!code)
 469     return build_empty_stmt ();
 470
 471   gfc_start_block (&block);
 472
 473   /* Translate statements one by one to GIMPLE trees until we reach
 474      the end of this gfc_code branch.  */
 475   for (; code; code = code->next)
 476     {
 477       gfc_set_backend_locus (&code->loc);
 478
 479       if (code->here != 0)
 480         {
 481           res = gfc_trans_label_here (code);
 482           gfc_add_expr_to_block (&block, res);
 483         }
 484
 485       switch (code->op)
 486         {
 487         case EXEC_NOP:
 488           res = NULL_TREE;
 489           break;
 490
 491         case EXEC_ASSIGN:
 492           res = gfc_trans_assign (code);
 493           break;
 494
 495         case EXEC_LABEL_ASSIGN:
 496           res = gfc_trans_label_assign (code);
 497           break;
 498
 499         case EXEC_POINTER_ASSIGN:
 500           res = gfc_trans_pointer_assign (code);
 501           break;
 502
 503         case EXEC_CONTINUE:
 504           res = NULL_TREE;
 505           break;
 506
 507         case EXEC_CYCLE:
 508           res = gfc_trans_cycle (code);
 509           break;
 510
 511         case EXEC_EXIT:
 512           res = gfc_trans_exit (code);
 513           break;
 514
 515         case EXEC_GOTO:
 516           res = gfc_trans_goto (code);
 517           break;
 518
 519         case EXEC_ENTRY:
 520           res = gfc_trans_entry (code);
 521           break;
 522
 523         case EXEC_PAUSE:
 524           res = gfc_trans_pause (code);
 525           break;
 526
 527         case EXEC_STOP:
 528           res = gfc_trans_stop (code);
 529           break;
 530
 531         case EXEC_CALL:
 532           res = gfc_trans_call (code);
 533           break;
 534
 535         case EXEC_RETURN:
 536           res = gfc_trans_return (code);
 537           break;
 538
 539         case EXEC_IF:
 540           res = gfc_trans_if (code);
 541           break;
 542
 543         case EXEC_ARITHMETIC_IF:
 544           res = gfc_trans_arithmetic_if (code);
 545           break;
 546
 547         case EXEC_DO:
 548           res = gfc_trans_do (code);
 549           break;
 550
 551         case EXEC_DO_WHILE:
 552           res = gfc_trans_do_while (code);
 553           break;
 554
 555         case EXEC_SELECT:
 556           res = gfc_trans_select (code);
 557           break;
 558
 559         case EXEC_FORALL:
 560           res = gfc_trans_forall (code);
 561           break;
 562
 563         case EXEC_WHERE:
 564           res = gfc_trans_where (code);
 565           break;
 566
 567         case EXEC_ALLOCATE:
 568           res = gfc_trans_allocate (code);
 569           break;
 570
 571         case EXEC_DEALLOCATE:
 572           res = gfc_trans_deallocate (code);
 573           break;
 574
 575         case EXEC_OPEN:
 576           res = gfc_trans_open (code);
 577           break;
 578
 579         case EXEC_CLOSE:
 580           res = gfc_trans_close (code);
 581           break;
 582
 583         case EXEC_READ:
 584           res = gfc_trans_read (code);
 585           break;
 586
 587         case EXEC_WRITE:
 588           res = gfc_trans_write (code);
 589           break;
 590
 591         case EXEC_IOLENGTH:
 592           res = gfc_trans_iolength (code);
 593           break;
 594
 595         case EXEC_BACKSPACE:
 596           res = gfc_trans_backspace (code);
 597           break;
 598
 599         case EXEC_ENDFILE:
 600           res = gfc_trans_endfile (code);
 601           break;
 602
 603         case EXEC_INQUIRE:
 604           res = gfc_trans_inquire (code);
 605           break;
 606
 607         case EXEC_REWIND:
 608           res = gfc_trans_rewind (code);
 609           break;
 610
 611         case EXEC_TRANSFER:
 612           res = gfc_trans_transfer (code);
 613           break;
 614
 615         case EXEC_DT_END:
 616           res = gfc_trans_dt_end (code);
 617           break;
 618
 619         default:
 620           internal_error ("gfc_trans_code(): Bad statement code");
 621         }
 622
 623       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 624         {
 625           if (TREE_CODE (res) == STATEMENT_LIST)
 626             annotate_all_with_locus (&res, input_location);
 627           else
 628             annotate_with_locus (res, input_location);
 629
 630           /* Add the new statemment to the block.  */
 631           gfc_add_expr_to_block (&block, res);
 632         }
 633     }
 634
 635   /* Return the finished block.  */
 636   return gfc_finish_block (&block);
 637 }
 638
 639
 640 /* This function is called after a complete program unit has been parsed
 641    and resolved.  */
 642
 643 void
 644 gfc_generate_code (gfc_namespace * ns)
 645 {
 646   gfc_symbol *main_program = NULL;
 647   symbol_attribute attr;
 648
 649   /* Main program subroutine.  */
 650   if (!ns->proc_name)
 651     {
 652       /* Lots of things get upset if a subroutine doesn't have a symbol, so we
 653          make one now.  Hopefully we've set all the required fields.  */
 654       gfc_get_symbol ("MAIN__", ns, &main_program);
 655       gfc_clear_attr (&attr);
 656       attr.flavor = FL_PROCEDURE;
 657       attr.proc = PROC_UNKNOWN;
 658       attr.subroutine = 1;
 659       attr.access = ACCESS_PUBLIC;
 660       main_program->attr = attr;
 661       ns->proc_name = main_program;
 662       gfc_commit_symbols ();
 663     }
 664
 665   gfc_generate_function_code (ns);
 666 }
 667
 668
 669 /* This function is called after a complete module has been parsed
 670    and resolved.  */
 671
 672 void
 673 gfc_generate_module_code (gfc_namespace * ns)
 674 {
 675   gfc_namespace *n;
 676
 677   gfc_generate_module_vars (ns);
 678
 679   /* We need to generate all module function prototypes first, to allow
 680      sibling calls.  */
 681   for (n = ns->contained; n; n = n->sibling)
 682     {
 683       if (!n->proc_name)
 684         continue;
 685
 686       gfc_create_function_decl (n);
 687     }
 688
 689   for (n = ns->contained; n; n = n->sibling)
 690     {
 691       if (!n->proc_name)
 692         continue;
 693
 694       gfc_generate_function_code (n);
 695     }
 696 }
 697