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