gcc/fortran/trans.c

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