gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
   3    Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "coretypes.h"
  26 #include "tree.h"
  27 #include "tree-gimple.h"
  28 #include "ggc.h"
  29 #include "toplev.h"
  30 #include "defaults.h"
  31 #include "real.h"
  32 #include "gfortran.h"
  33 #include "trans.h"
  34 #include "trans-stmt.h"
  35 #include "trans-array.h"
  36 #include "trans-types.h"
  37 #include "trans-const.h"
  38
  39 /* Naming convention for backend interface code:
  40
  41    gfc_trans_*  translate gfc_code into STMT trees.
  42
  43    gfc_conv_*   expression conversion
  44
  45    gfc_get_*    get a backend tree representation of a decl or type  */
  46
  47 static gfc_file *gfc_current_backend_file;
  48
  49 char gfc_msg_bounds[] = N_("Array bound mismatch");
  50 char gfc_msg_fault[] = N_("Array reference out of bounds");
  51 char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  52
  53
  54 /* Advance along TREE_CHAIN n times.  */
  55
  56 tree
  57 gfc_advance_chain (tree t, int n)
  58 {
  59   for (; n > 0; n--)
  60     {
  61       gcc_assert (t != NULL_TREE);
  62       t = TREE_CHAIN (t);
  63     }
  64   return t;
  65 }
  66
  67
  68 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  69
  70 tree
  71 gfc_chainon_list (tree list, tree add)
  72 {
  73   tree l;
  74
  75   l = tree_cons (NULL_TREE, add, NULL_TREE);
  76
  77   return chainon (list, l);
  78 }
  79
  80
  81 /* Strip off a legitimate source ending from the input
  82    string NAME of length LEN.  */
  83
  84 static inline void
  85 remove_suffix (char *name, int len)
  86 {
  87   int i;
  88
  89   for (i = 2; i < 8 && len > i; i++)
  90     {
  91       if (name[len - i] == '.')
  92         {
  93           name[len - i] = '\0';
  94           break;
  95         }
  96     }
  97 }
  98
  99
 100 /* Creates a variable declaration with a given TYPE.  */
 101
 102 tree
 103 gfc_create_var_np (tree type, const char *prefix)
 104 {
 105   return create_tmp_var_raw (type, prefix);
 106 }
 107
 108
 109 /* Like above, but also adds it to the current scope.  */
 110
 111 tree
 112 gfc_create_var (tree type, const char *prefix)
 113 {
 114   tree tmp;
 115
 116   tmp = gfc_create_var_np (type, prefix);
 117
 118   pushdecl (tmp);
 119
 120   return tmp;
 121 }
 122
 123
 124 /* If the an expression is not constant, evaluate it now.  We assign the
 125    result of the expression to an artificially created variable VAR, and
 126    return a pointer to the VAR_DECL node for this variable.  */
 127
 128 tree
 129 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 130 {
 131   tree var;
 132
 133   if (CONSTANT_CLASS_P (expr))
 134     return expr;
 135
 136   var = gfc_create_var (TREE_TYPE (expr), NULL);
 137   gfc_add_modify_expr (pblock, var, expr);
 138
 139   return var;
 140 }
 141
 142
 143 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
 144    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
 145    LHS <- RHS.  */
 146
 147 void
 148 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
 149                 bool tuples_p)
 150 {
 151   tree tmp;
 152
 153 #ifdef ENABLE_CHECKING
 154   /* Make sure that the types of the rhs and the lhs are the same
 155      for scalar assignments.  We should probably have something
 156      similar for aggregates, but right now removing that check just
 157      breaks everything.  */
 158   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
 159               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 160 #endif
 161
 162   tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
 163                      void_type_node, lhs, rhs);
 164   gfc_add_expr_to_block (pblock, tmp);
 165 }
 166
 167
 168 /* Create a new scope/binding level and initialize a block.  Care must be
 169    taken when translating expressions as any temporaries will be placed in
 170    the innermost scope.  */
 171
 172 void
 173 gfc_start_block (stmtblock_t * block)
 174 {
 175   /* Start a new binding level.  */
 176   pushlevel (0);
 177   block->has_scope = 1;
 178
 179   /* The block is empty.  */
 180   block->head = NULL_TREE;
 181 }
 182
 183
 184 /* Initialize a block without creating a new scope.  */
 185
 186 void
 187 gfc_init_block (stmtblock_t * block)
 188 {
 189   block->head = NULL_TREE;
 190   block->has_scope = 0;
 191 }
 192
 193
 194 /* Sometimes we create a scope but it turns out that we don't actually
 195    need it.  This function merges the scope of BLOCK with its parent.
 196    Only variable decls will be merged, you still need to add the code.  */
 197
 198 void
 199 gfc_merge_block_scope (stmtblock_t * block)
 200 {
 201   tree decl;
 202   tree next;
 203
 204   gcc_assert (block->has_scope);
 205   block->has_scope = 0;
 206
 207   /* Remember the decls in this scope.  */
 208   decl = getdecls ();
 209   poplevel (0, 0, 0);
 210
 211   /* Add them to the parent scope.  */
 212   while (decl != NULL_TREE)
 213     {
 214       next = TREE_CHAIN (decl);
 215       TREE_CHAIN (decl) = NULL_TREE;
 216
 217       pushdecl (decl);
 218       decl = next;
 219     }
 220 }
 221
 222
 223 /* Finish a scope containing a block of statements.  */
 224
 225 tree
 226 gfc_finish_block (stmtblock_t * stmtblock)
 227 {
 228   tree decl;
 229   tree expr;
 230   tree block;
 231
 232   expr = stmtblock->head;
 233   if (!expr)
 234     expr = build_empty_stmt ();
 235
 236   stmtblock->head = NULL_TREE;
 237
 238   if (stmtblock->has_scope)
 239     {
 240       decl = getdecls ();
 241
 242       if (decl)
 243         {
 244           block = poplevel (1, 0, 0);
 245           expr = build3_v (BIND_EXPR, decl, expr, block);
 246         }
 247       else
 248         poplevel (0, 0, 0);
 249     }
 250
 251   return expr;
 252 }
 253
 254
 255 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 256    natural type is used.  */
 257
 258 tree
 259 gfc_build_addr_expr (tree type, tree t)
 260 {
 261   tree base_type = TREE_TYPE (t);
 262   tree natural_type;
 263
 264   if (type && POINTER_TYPE_P (type)
 265       && TREE_CODE (base_type) == ARRAY_TYPE
 266       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 267          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 268     natural_type = type;
 269   else
 270     natural_type = build_pointer_type (base_type);
 271
 272   if (TREE_CODE (t) == INDIRECT_REF)
 273     {
 274       if (!type)
 275         type = natural_type;
 276       t = TREE_OPERAND (t, 0);
 277       natural_type = TREE_TYPE (t);
 278     }
 279   else
 280     {
 281       if (DECL_P (t))
 282         TREE_ADDRESSABLE (t) = 1;
 283       t = build1 (ADDR_EXPR, natural_type, t);
 284     }
 285
 286   if (type && natural_type != type)
 287     t = convert (type, t);
 288
 289   return 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   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 300   type = TREE_TYPE (type);
 301
 302   if (DECL_P (base))
 303     TREE_ADDRESSABLE (base) = 1;
 304
 305   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 306 }
 307
 308
 309 /* Generate a runtime error if COND is true.  */
 310
 311 void
 312 gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
 313                          locus * where)
 314 {
 315   stmtblock_t block;
 316   tree body;
 317   tree tmp;
 318   tree args;
 319   char * message;
 320   int line;
 321
 322   if (integer_zerop (cond))
 323     return;
 324
 325   /* The code to generate the error.  */
 326   gfc_start_block (&block);
 327
 328   if (where)
 329     {
 330 #ifdef USE_MAPPED_LOCATION
 331       line = LOCATION_LINE (where->lb->location);
 332 #else
 333       line = where->lb->linenum;
 334 #endif
 335       asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
 336                 where->lb->file->filename, line);
 337     }
 338   else
 339     asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
 340               gfc_source_file, input_line + 1);
 341
 342   tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 343   gfc_free(message);
 344   args = gfc_chainon_list (NULL_TREE, tmp);
 345
 346   tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
 347   gfc_add_expr_to_block (&block, tmp);
 348
 349   body = gfc_finish_block (&block);
 350
 351   if (integer_onep (cond))
 352     {
 353       gfc_add_expr_to_block (pblock, body);
 354     }
 355   else
 356     {
 357       /* Tell the compiler that this isn't likely.  */
 358       cond = fold_convert (long_integer_type_node, cond);
 359       tmp = gfc_chainon_list (NULL_TREE, cond);
 360       tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0));
 361       cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
 362       cond = fold_convert (boolean_type_node, cond);
 363
 364       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 365       gfc_add_expr_to_block (pblock, tmp);
 366     }
 367 }
 368
 369
 370 /* Add a statement to a block.  */
 371
 372 void
 373 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 374 {
 375   gcc_assert (block);
 376
 377   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 378     return;
 379
 380   if (block->head)
 381     {
 382       if (TREE_CODE (block->head) != STATEMENT_LIST)
 383         {
 384           tree tmp;
 385
 386           tmp = block->head;
 387           block->head = NULL_TREE;
 388           append_to_statement_list (tmp, &block->head);
 389         }
 390       append_to_statement_list (expr, &block->head);
 391     }
 392   else
 393     /* Don't bother creating a list if we only have a single statement.  */
 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   gcc_assert (append);
 404   gcc_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_backend_locus.  */
 413
 414 void
 415 gfc_get_backend_locus (locus * loc)
 416 {
 417   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 418 #ifdef USE_MAPPED_LOCATION
 419   loc->lb->location = input_location;
 420 #else
 421   loc->lb->linenum = input_line;
 422 #endif
 423   loc->lb->file = gfc_current_backend_file;
 424 }
 425
 426
 427 /* Set the current locus.  */
 428
 429 void
 430 gfc_set_backend_locus (locus * loc)
 431 {
 432   gfc_current_backend_file = loc->lb->file;
 433 #ifdef USE_MAPPED_LOCATION
 434   input_location = loc->lb->location;
 435 #else
 436   input_line = loc->lb->linenum;
 437   input_filename = loc->lb->file->filename;
 438 #endif
 439 }
 440
 441
 442 /* Translate an executable statement.  */
 443
 444 tree
 445 gfc_trans_code (gfc_code * code)
 446 {
 447   stmtblock_t block;
 448   tree res;
 449
 450   if (!code)
 451     return build_empty_stmt ();
 452
 453   gfc_start_block (&block);
 454
 455   /* Translate statements one by one to GIMPLE trees until we reach
 456      the end of this gfc_code branch.  */
 457   for (; code; code = code->next)
 458     {
 459       if (code->here != 0)
 460         {
 461           res = gfc_trans_label_here (code);
 462           gfc_add_expr_to_block (&block, res);
 463         }
 464
 465       switch (code->op)
 466         {
 467         case EXEC_NOP:
 468           res = NULL_TREE;
 469           break;
 470
 471         case EXEC_ASSIGN:
 472           res = gfc_trans_assign (code);
 473           break;
 474
 475         case EXEC_LABEL_ASSIGN:
 476           res = gfc_trans_label_assign (code);
 477           break;
 478
 479         case EXEC_POINTER_ASSIGN:
 480           res = gfc_trans_pointer_assign (code);
 481           break;
 482
 483         case EXEC_INIT_ASSIGN:
 484           res = gfc_trans_init_assign (code);
 485           break;
 486
 487         case EXEC_CONTINUE:
 488           res = NULL_TREE;
 489           break;
 490
 491         case EXEC_CYCLE:
 492           res = gfc_trans_cycle (code);
 493           break;
 494
 495         case EXEC_EXIT:
 496           res = gfc_trans_exit (code);
 497           break;
 498
 499         case EXEC_GOTO:
 500           res = gfc_trans_goto (code);
 501           break;
 502
 503         case EXEC_ENTRY:
 504           res = gfc_trans_entry (code);
 505           break;
 506
 507         case EXEC_PAUSE:
 508           res = gfc_trans_pause (code);
 509           break;
 510
 511         case EXEC_STOP:
 512           res = gfc_trans_stop (code);
 513           break;
 514
 515         case EXEC_CALL:
 516           res = gfc_trans_call (code, false);
 517           break;
 518
 519         case EXEC_ASSIGN_CALL:
 520           res = gfc_trans_call (code, true);
 521           break;
 522
 523         case EXEC_RETURN:
 524           res = gfc_trans_return (code);
 525           break;
 526
 527         case EXEC_IF:
 528           res = gfc_trans_if (code);
 529           break;
 530
 531         case EXEC_ARITHMETIC_IF:
 532           res = gfc_trans_arithmetic_if (code);
 533           break;
 534
 535         case EXEC_DO:
 536           res = gfc_trans_do (code);
 537           break;
 538
 539         case EXEC_DO_WHILE:
 540           res = gfc_trans_do_while (code);
 541           break;
 542
 543         case EXEC_SELECT:
 544           res = gfc_trans_select (code);
 545           break;
 546
 547         case EXEC_FLUSH:
 548           res = gfc_trans_flush (code);
 549           break;
 550
 551         case EXEC_FORALL:
 552           res = gfc_trans_forall (code);
 553           break;
 554
 555         case EXEC_WHERE:
 556           res = gfc_trans_where (code);
 557           break;
 558
 559         case EXEC_ALLOCATE:
 560           res = gfc_trans_allocate (code);
 561           break;
 562
 563         case EXEC_DEALLOCATE:
 564           res = gfc_trans_deallocate (code);
 565           break;
 566
 567         case EXEC_OPEN:
 568           res = gfc_trans_open (code);
 569           break;
 570
 571         case EXEC_CLOSE:
 572           res = gfc_trans_close (code);
 573           break;
 574
 575         case EXEC_READ:
 576           res = gfc_trans_read (code);
 577           break;
 578
 579         case EXEC_WRITE:
 580           res = gfc_trans_write (code);
 581           break;
 582
 583         case EXEC_IOLENGTH:
 584           res = gfc_trans_iolength (code);
 585           break;
 586
 587         case EXEC_BACKSPACE:
 588           res = gfc_trans_backspace (code);
 589           break;
 590
 591         case EXEC_ENDFILE:
 592           res = gfc_trans_endfile (code);
 593           break;
 594
 595         case EXEC_INQUIRE:
 596           res = gfc_trans_inquire (code);
 597           break;
 598
 599         case EXEC_REWIND:
 600           res = gfc_trans_rewind (code);
 601           break;
 602
 603         case EXEC_TRANSFER:
 604           res = gfc_trans_transfer (code);
 605           break;
 606
 607         case EXEC_DT_END:
 608           res = gfc_trans_dt_end (code);
 609           break;
 610
 611         case EXEC_OMP_ATOMIC:
 612         case EXEC_OMP_BARRIER:
 613         case EXEC_OMP_CRITICAL:
 614         case EXEC_OMP_DO:
 615         case EXEC_OMP_FLUSH:
 616         case EXEC_OMP_MASTER:
 617         case EXEC_OMP_ORDERED:
 618         case EXEC_OMP_PARALLEL:
 619         case EXEC_OMP_PARALLEL_DO:
 620         case EXEC_OMP_PARALLEL_SECTIONS:
 621         case EXEC_OMP_PARALLEL_WORKSHARE:
 622         case EXEC_OMP_SECTIONS:
 623         case EXEC_OMP_SINGLE:
 624         case EXEC_OMP_WORKSHARE:
 625           res = gfc_trans_omp_directive (code);
 626           break;
 627
 628         default:
 629           internal_error ("gfc_trans_code(): Bad statement code");
 630         }
 631
 632       gfc_set_backend_locus (&code->loc);
 633
 634       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 635         {
 636           if (TREE_CODE (res) == STATEMENT_LIST)
 637             annotate_all_with_locus (&res, input_location);
 638           else
 639             SET_EXPR_LOCATION (res, input_location);
 640
 641           /* Add the new statement to the block.  */
 642           gfc_add_expr_to_block (&block, res);
 643         }
 644     }
 645
 646   /* Return the finished block.  */
 647   return gfc_finish_block (&block);
 648 }
 649
 650
 651 /* This function is called after a complete program unit has been parsed
 652    and resolved.  */
 653
 654 void
 655 gfc_generate_code (gfc_namespace * ns)
 656 {
 657   if (ns->is_block_data)
 658     {
 659       gfc_generate_block_data (ns);
 660       return;
 661     }
 662
 663   gfc_generate_function_code (ns);
 664 }
 665
 666
 667 /* This function is called after a complete module has been parsed
 668    and resolved.  */
 669
 670 void
 671 gfc_generate_module_code (gfc_namespace * ns)
 672 {
 673   gfc_namespace *n;
 674
 675   gfc_generate_module_vars (ns);
 676
 677   /* We need to generate all module function prototypes first, to allow
 678      sibling calls.  */
 679   for (n = ns->contained; n; n = n->sibling)
 680     {
 681       if (!n->proc_name)
 682         continue;
 683
 684       gfc_create_function_decl (n);
 685     }
 686
 687   for (n = ns->contained; n; n = n->sibling)
 688     {
 689       if (!n->proc_name)
 690         continue;
 691
 692       gfc_generate_function_code (n);
 693     }
 694 }
 695