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