gcc/fortran/f95-lang.c

   1 /* gfortran backend interface
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  22
  23 /* f95-lang.c-- GCC backend interface stuff */
  24
  25 /* declare required prototypes: */
  26
  27 #include "config.h"
  28 #include "ansidecl.h"
  29 #include "system.h"
  30 #include "coretypes.h"
  31 #include "tree.h"
  32 #include "tree-gimple.h"
  33 #include "flags.h"
  34 #include "langhooks.h"
  35 #include "langhooks-def.h"
  36 #include "timevar.h"
  37 #include "tm.h"
  38 #include "function.h"
  39 #include "ggc.h"
  40 #include "toplev.h"
  41 #include "target.h"
  42 #include "debug.h"
  43 #include "diagnostic.h"
  44 #include "tree-dump.h"
  45 #include "cgraph.h"
  46
  47 #include "gfortran.h"
  48 #include "trans.h"
  49 #include "trans-types.h"
  50 #include "trans-const.h"
  51
  52 #include <stdio.h>
  53
  54 /* Language-dependent contents of an identifier.  */
  55
  56 struct lang_identifier
  57 GTY(())
  58 {
  59   struct tree_identifier common;
  60 };
  61
  62 /* The resulting tree type.  */
  63
  64 union lang_tree_node
  65 GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE")))
  66 {
  67   union tree_node GTY((tag ("0"),
  68                        desc ("tree_node_structure (&%h)"))) generic;
  69   struct lang_identifier GTY((tag ("1"))) identifier;
  70 };
  71
  72 /* Save and restore the variables in this file and elsewhere
  73    that keep track of the progress of compilation of the current function.
  74    Used for nested functions.  */
  75
  76 struct language_function
  77 GTY(())
  78 {
  79   /* struct gfc_language_function base; */
  80   tree named_labels;
  81   tree shadowed_labels;
  82   int returns_value;
  83   int returns_abnormally;
  84   int warn_about_return_type;
  85   int extern_inline;
  86   struct binding_level *binding_level;
  87 };
  88
  89 /* We don't have a lex/yacc lexer/parser, but toplev expects these to
  90    exist anyway.  */
  91 void yyerror (const char *str);
  92 int yylex (void);
  93
  94 static void gfc_init_decl_processing (void);
  95 static void gfc_init_builtin_functions (void);
  96
  97 /* Each front end provides its own.  */
  98 static bool gfc_init (void);
  99 static void gfc_finish (void);
 100 static void gfc_print_identifier (FILE *, tree, int);
 101 static bool gfc_mark_addressable (tree);
 102 void do_function_end (void);
 103 int global_bindings_p (void);
 104 void insert_block (tree);
 105 static void gfc_clear_binding_stack (void);
 106 static void gfc_be_parse_file (int);
 107 static void gfc_expand_function (tree);
 108
 109 #undef LANG_HOOKS_NAME
 110 #undef LANG_HOOKS_INIT
 111 #undef LANG_HOOKS_FINISH
 112 #undef LANG_HOOKS_INIT_OPTIONS
 113 #undef LANG_HOOKS_HANDLE_OPTION
 114 #undef LANG_HOOKS_POST_OPTIONS
 115 #undef LANG_HOOKS_PRINT_IDENTIFIER
 116 #undef LANG_HOOKS_PARSE_FILE
 117 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
 118 #undef LANG_HOOKS_MARK_ADDRESSABLE
 119 #undef LANG_HOOKS_TYPE_FOR_MODE
 120 #undef LANG_HOOKS_TYPE_FOR_SIZE
 121 #undef LANG_HOOKS_UNSIGNED_TYPE
 122 #undef LANG_HOOKS_SIGNED_TYPE
 123 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 124 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 125 #undef LANG_HOOKS_CLEAR_BINDING_STACK
 126
 127 /* Define lang hooks.  */
 128 #define LANG_HOOKS_NAME                 "GNU F95"
 129 #define LANG_HOOKS_INIT                 gfc_init
 130 #define LANG_HOOKS_FINISH               gfc_finish
 131 #define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
 132 #define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
 133 #define LANG_HOOKS_POST_OPTIONS         gfc_post_options
 134 #define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
 135 #define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
 136 #define LANG_HOOKS_TRUTHVALUE_CONVERSION   gfc_truthvalue_conversion
 137 #define LANG_HOOKS_MARK_ADDRESSABLE        gfc_mark_addressable
 138 #define LANG_HOOKS_TYPE_FOR_MODE           gfc_type_for_mode
 139 #define LANG_HOOKS_TYPE_FOR_SIZE           gfc_type_for_size
 140 #define LANG_HOOKS_UNSIGNED_TYPE           gfc_unsigned_type
 141 #define LANG_HOOKS_SIGNED_TYPE             gfc_signed_type
 142 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
 143 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
 144 #define LANG_HOOKS_CLEAR_BINDING_STACK     gfc_clear_binding_stack
 145
 146 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 147
 148 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 149    that have names.  Here so we can clear out their names' definitions
 150    at the end of the function.  */
 151
 152 /* Tree code classes.  */
 153
 154 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 155
 156 const char tree_code_type[] = {
 157 #include "tree.def"
 158 };
 159 #undef DEFTREECODE
 160
 161 /* Table indexed by tree code giving number of expression
 162    operands beyond the fixed part of the node structure.
 163    Not used for types or decls.  */
 164
 165 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 166
 167 const unsigned char tree_code_length[] = {
 168 #include "tree.def"
 169 };
 170 #undef DEFTREECODE
 171
 172 /* Names of tree components.
 173    Used for printing out the tree and error messages.  */
 174 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 175
 176 const char *const tree_code_name[] = {
 177 #include "tree.def"
 178 };
 179 #undef DEFTREECODE
 180
 181 static tree named_labels;
 182
 183 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 184
 185 /* A chain of binding_level structures awaiting reuse.  */
 186
 187 static GTY(()) struct binding_level *free_binding_level;
 188
 189 /* The elements of `ridpointers' are identifier nodes
 190    for the reserved type names and storage classes.
 191    It is indexed by a RID_... value.  */
 192 tree *ridpointers = NULL;
 193
 194 /* language-specific flags.  */
 195
 196 static void
 197 gfc_expand_function (tree fndecl)
 198 {
 199   tree_rest_of_compilation (fndecl, 0);
 200 }
 201 \f
 202
 203 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
 204    or validate its data type for an `if' or `while' statement or ?..: exp.
 205
 206    This preparation consists of taking the ordinary
 207    representation of an expression expr and producing a valid tree
 208    boolean expression describing whether expr is nonzero.  We could
 209    simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
 210    but we optimize comparisons, &&, ||, and !.
 211
 212    The resulting type should always be `boolean_type_node'.
 213    This is much simpler than the corresponding C version because we have a
 214    distinct boolean type.  */
 215
 216 tree
 217 gfc_truthvalue_conversion (tree expr)
 218 {
 219   switch (TREE_CODE (TREE_TYPE (expr)))
 220     {
 221     case BOOLEAN_TYPE:
 222       if (TREE_TYPE (expr) == boolean_type_node)
 223         return expr;
 224       else if (TREE_CODE_CLASS (TREE_CODE (expr)) == '<')
 225         {
 226           TREE_TYPE (expr) = boolean_type_node;
 227           return expr;
 228         }
 229       else if (TREE_CODE (expr) == NOP_EXPR)
 230         return build1 (NOP_EXPR, boolean_type_node,
 231                        TREE_OPERAND (expr, 0));
 232       else
 233         return build1 (NOP_EXPR, boolean_type_node, expr);
 234
 235     case INTEGER_TYPE:
 236       if (TREE_CODE (expr) == INTEGER_CST)
 237         return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
 238       else
 239         return build2 (NE_EXPR, boolean_type_node, expr, integer_zero_node);
 240
 241     default:
 242       internal_error ("Unexpected type in truthvalue_conversion");
 243     }
 244 }
 245
 246 static void
 247 gfc_create_decls (void)
 248 {
 249   /* GCC builtins.  */
 250   gfc_init_builtin_functions ();
 251
 252   /* Runtime/IO library functions.  */
 253   gfc_build_builtin_function_decls ();
 254
 255   gfc_init_constants ();
 256 }
 257
 258 static void
 259 gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 260 {
 261   int errors;
 262   int warnings;
 263
 264   gfc_create_decls ();
 265   gfc_parse_file ();
 266   gfc_generate_constructors ();
 267
 268   cgraph_finalize_compilation_unit ();
 269   cgraph_optimize ();
 270
 271   /* Tell the frontent about any errors.  */
 272   gfc_get_errors (&warnings, &errors);
 273   errorcount += errors;
 274   warningcount += warnings;
 275 }
 276 \f
 277 /* Initialize everything.  */
 278
 279 static bool
 280 gfc_init (void)
 281 {
 282 #ifdef USE_MAPPED_LOCATION
 283   linemap_add (&line_table, LC_ENTER, false, gfc_option.source, 1);
 284   linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
 285 #endif
 286
 287   /* First initialize the backend.  */
 288   gfc_init_decl_processing ();
 289   gfc_static_ctors = NULL_TREE;
 290
 291   /* Then the frontend.  */
 292   gfc_init_1 ();
 293
 294   if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS)
 295     fatal_error ("can't open input file: %s", gfc_option.source);
 296   return true;
 297 }
 298
 299
 300 static void
 301 gfc_finish (void)
 302 {
 303   gfc_done_1 ();
 304   gfc_release_include_path ();
 305   return;
 306 }
 307
 308 static void
 309 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 310                       tree node ATTRIBUTE_UNUSED,
 311                       int indent ATTRIBUTE_UNUSED)
 312 {
 313   return;
 314 }
 315 \f
 316
 317 /* These functions and variables deal with binding contours.  We only
 318    need these functions for the list of PARM_DECLs, but we leave the
 319    functions more general; these are a simplified version of the
 320    functions from GNAT.  */
 321
 322 /* For each binding contour we allocate a binding_level structure which records
 323    the entities defined or declared in that contour. Contours include:
 324
 325         the global one
 326         one for each subprogram definition
 327         one for each compound statement (declare block)
 328
 329    Binding contours are used to create GCC tree BLOCK nodes.  */
 330
 331 struct binding_level
 332 GTY(())
 333 {
 334   /* A chain of ..._DECL nodes for all variables, constants, functions,
 335      parameters and type declarations.  These ..._DECL nodes are chained
 336      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 337      in the reverse of the order supplied to be compatible with the
 338      back-end.  */
 339   tree names;
 340   /* For each level (except the global one), a chain of BLOCK nodes for all
 341      the levels that were entered and exited one level down from this one.  */
 342   tree blocks;
 343   /* The binding level containing this one (the enclosing binding level). */
 344   struct binding_level *level_chain;
 345 };
 346
 347 /* The binding level currently in effect.  */
 348 static GTY(()) struct binding_level *current_binding_level = NULL;
 349
 350 /* The outermost binding level. This binding level is created when the
 351    compiler is started and it will exist through the entire compilation.  */
 352 static GTY(()) struct binding_level *global_binding_level;
 353
 354 /* Binding level structures are initialized by copying this one.  */
 355 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 356 \f
 357 /* Return nonzero if we are currently in the global binding level.  */
 358
 359 int
 360 global_bindings_p (void)
 361 {
 362   return current_binding_level == global_binding_level ? -1 : 0;
 363 }
 364
 365 tree
 366 getdecls (void)
 367 {
 368   return current_binding_level->names;
 369 }
 370
 371 /* Enter a new binding level. The input parameter is ignored, but has to be
 372    specified for back-end compatibility.  */
 373
 374 void
 375 pushlevel (int ignore ATTRIBUTE_UNUSED)
 376 {
 377   struct binding_level *newlevel
 378     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 379
 380   *newlevel = clear_binding_level;
 381
 382   /* Add this level to the front of the chain (stack) of levels that are
 383      active.  */
 384   newlevel->level_chain = current_binding_level;
 385   current_binding_level = newlevel;
 386 }
 387
 388 /* Exit a binding level.
 389    Pop the level off, and restore the state of the identifier-decl mappings
 390    that were in effect when this level was entered.
 391
 392    If KEEP is nonzero, this level had explicit declarations, so
 393    and create a "block" (a BLOCK node) for the level
 394    to record its declarations and subblocks for symbol table output.
 395
 396    If FUNCTIONBODY is nonzero, this level is the body of a function,
 397    so create a block as if KEEP were set and also clear out all
 398    label names.
 399
 400    If REVERSE is nonzero, reverse the order of decls before putting
 401    them into the BLOCK.  */
 402
 403 tree
 404 poplevel (int keep, int reverse, int functionbody)
 405 {
 406   /* Points to a BLOCK tree node. This is the BLOCK node construted for the
 407      binding level that we are about to exit and which is returned by this
 408      routine.  */
 409   tree block_node = NULL_TREE;
 410   tree decl_chain;
 411   tree subblock_chain = current_binding_level->blocks;
 412   tree subblock_node;
 413
 414   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 415      nodes chained through the `names' field of current_binding_level are in
 416      reverse order except for PARM_DECL node, which are explicitely stored in
 417      the right order.  */
 418   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 419     : current_binding_level->names;
 420
 421   /* If there were any declarations in the current binding level, or if this
 422      binding level is a function body, or if there are any nested blocks then
 423      create a BLOCK node to record them for the life of this function.  */
 424   if (keep || functionbody)
 425     block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
 426
 427   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 428   for (subblock_node = subblock_chain; subblock_node;
 429        subblock_node = TREE_CHAIN (subblock_node))
 430     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 431
 432   /* Clear out the meanings of the local variables of this level.  */
 433
 434   for (subblock_node = decl_chain; subblock_node;
 435        subblock_node = TREE_CHAIN (subblock_node))
 436     if (DECL_NAME (subblock_node) != 0)
 437       /* If the identifier was used or addressed via a local extern decl,
 438          don't forget that fact.   */
 439       if (DECL_EXTERNAL (subblock_node))
 440         {
 441           if (TREE_USED (subblock_node))
 442             TREE_USED (DECL_NAME (subblock_node)) = 1;
 443           if (TREE_ADDRESSABLE (subblock_node))
 444             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 445         }
 446
 447   /* Pop the current level.  */
 448   current_binding_level = current_binding_level->level_chain;
 449
 450   if (functionbody)
 451     {
 452       /* This is the top level block of a function. The ..._DECL chain stored
 453          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 454          leave them in the BLOCK because they are found in the FUNCTION_DECL
 455          instead.  */
 456       DECL_INITIAL (current_function_decl) = block_node;
 457       BLOCK_VARS (block_node) = 0;
 458     }
 459   else if (block_node)
 460     {
 461       current_binding_level->blocks
 462         = chainon (current_binding_level->blocks, block_node);
 463     }
 464
 465   /* If we did not make a block for the level just exited, any blocks made for
 466      inner levels (since they cannot be recorded as subblocks in that level)
 467      must be carried forward so they will later become subblocks of something
 468      else.  */
 469   else if (subblock_chain)
 470     current_binding_level->blocks
 471       = chainon (current_binding_level->blocks, subblock_chain);
 472   if (block_node)
 473     TREE_USED (block_node) = 1;
 474
 475   return block_node;
 476 }
 477 \f
 478 /* Insert BLOCK at the end of the list of subblocks of the
 479    current binding level.  This is used when a BIND_EXPR is expanded,
 480    to handle the BLOCK node inside the BIND_EXPR.  */
 481
 482 void
 483 insert_block (tree block)
 484 {
 485   TREE_USED (block) = 1;
 486   current_binding_level->blocks
 487     = chainon (current_binding_level->blocks, block);
 488 }
 489
 490 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 491    Returns the ..._DECL node. */
 492
 493 tree
 494 pushdecl (tree decl)
 495 {
 496   /* External objects aren't nested, other objects may be.  */
 497   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 498     DECL_CONTEXT (decl) = 0;
 499   else
 500     DECL_CONTEXT (decl) = current_function_decl;
 501
 502   /* Put the declaration on the list.  The list of declarations is in reverse
 503      order. The list will be reversed later if necessary.  This needs to be
 504      this way for compatibility with the back-end.  */
 505
 506   TREE_CHAIN (decl) = current_binding_level->names;
 507   current_binding_level->names = decl;
 508
 509   /* For the declartion of a type, set its name if it is not already set. */
 510
 511   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 512     {
 513       if (DECL_SOURCE_LINE (decl) == 0)
 514         TYPE_NAME (TREE_TYPE (decl)) = decl;
 515       else
 516         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 517     }
 518
 519   return decl;
 520 }
 521
 522
 523 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 524
 525 tree
 526 pushdecl_top_level (tree x)
 527 {
 528   tree t;
 529   struct binding_level *b = current_binding_level;
 530
 531   current_binding_level = global_binding_level;
 532   t = pushdecl (x);
 533   current_binding_level = b;
 534   return t;
 535 }
 536
 537
 538 /* Clear the binding stack.  */
 539 static void
 540 gfc_clear_binding_stack (void)
 541 {
 542   while (!global_bindings_p ())
 543     poplevel (0, 0, 0);
 544 }
 545
 546
 547 #ifndef CHAR_TYPE_SIZE
 548 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 549 #endif
 550
 551 #ifndef INT_TYPE_SIZE
 552 #define INT_TYPE_SIZE BITS_PER_WORD
 553 #endif
 554
 555 #undef SIZE_TYPE
 556 #define SIZE_TYPE "long unsigned int"
 557
 558 /* Create tree nodes for the basic scalar types of Fortran 95,
 559    and some nodes representing standard constants (0, 1, (void *) 0).
 560    Initialize the global binding level.
 561    Make definitions for built-in primitive functions.  */
 562 static void
 563 gfc_init_decl_processing (void)
 564 {
 565   current_function_decl = NULL;
 566   named_labels = NULL;
 567   current_binding_level = NULL_BINDING_LEVEL;
 568   free_binding_level = NULL_BINDING_LEVEL;
 569
 570   /* Make the binding_level structure for global names. We move all
 571      variables that are in a COMMON block to this binding level.  */
 572   pushlevel (0);
 573   global_binding_level = current_binding_level;
 574
 575   /* Build common tree nodes. char_type_node is unsigned because we
 576      only use it for actual characters, not for INTEGER(1). Also, we
 577      want double_type_node to actually have double precision.   */
 578   build_common_tree_nodes (false, false);
 579   set_sizetype (long_unsigned_type_node);
 580   build_common_tree_nodes_2 (0);
 581
 582   /* Set up F95 type nodes.  */
 583   gfc_init_kinds ();
 584   gfc_init_types ();
 585 }
 586
 587 /* Mark EXP saying that we need to be able to take the
 588    address of it; it should not be allocated in a register.
 589    In Fortran 95 this is only the case for variables with
 590    the TARGET attribute, but we implement it here for a
 591    likely future Cray pointer extension.
 592    Value is 1 if successful.  */
 593 /* TODO: Check/fix mark_addressable.  */
 594 bool
 595 gfc_mark_addressable (tree exp)
 596 {
 597   register tree x = exp;
 598   while (1)
 599     switch (TREE_CODE (x))
 600       {
 601       case COMPONENT_REF:
 602       case ADDR_EXPR:
 603       case ARRAY_REF:
 604       case REALPART_EXPR:
 605       case IMAGPART_EXPR:
 606         x = TREE_OPERAND (x, 0);
 607         break;
 608
 609       case CONSTRUCTOR:
 610         TREE_ADDRESSABLE (x) = 1;
 611         return true;
 612
 613       case VAR_DECL:
 614       case CONST_DECL:
 615       case PARM_DECL:
 616       case RESULT_DECL:
 617         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 618           {
 619             if (TREE_PUBLIC (x))
 620               {
 621                 error
 622                   ("global register variable `%s' used in nested function",
 623                    IDENTIFIER_POINTER (DECL_NAME (x)));
 624                 return false;
 625               }
 626             pedwarn ("register variable `%s' used in nested function",
 627                      IDENTIFIER_POINTER (DECL_NAME (x)));
 628           }
 629         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 630           {
 631             if (TREE_PUBLIC (x))
 632               {
 633                 error ("address of global register variable `%s' requested",
 634                        IDENTIFIER_POINTER (DECL_NAME (x)));
 635                 return true;
 636               }
 637
 638 #if 0
 639             /* If we are making this addressable due to its having
 640                volatile components, give a different error message.  Also
 641                handle the case of an unnamed parameter by not trying
 642                to give the name.  */
 643
 644             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 645               {
 646                 error ("cannot put object with volatile field into register");
 647                 return false;
 648               }
 649 #endif
 650
 651             pedwarn ("address of register variable `%s' requested",
 652                      IDENTIFIER_POINTER (DECL_NAME (x)));
 653           }
 654
 655         /* drops in */
 656       case FUNCTION_DECL:
 657         TREE_ADDRESSABLE (x) = 1;
 658
 659       default:
 660         return true;
 661       }
 662 }
 663
 664 /* press the big red button - garbage (ggc) collection is on */
 665
 666 int ggc_p = 1;
 667
 668 /* Builtin function initialisation.  */
 669
 670 /* Return a definition for a builtin function named NAME and whose data type
 671    is TYPE.  TYPE should be a function type with argument types.
 672    FUNCTION_CODE tells later passes how to compile calls to this function.
 673    See tree.h for its possible values.
 674
 675    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
 676    the name to be called if we can't opencode the function.  If
 677    ATTRS is nonzero, use that for the function's attribute list.  */
 678
 679 tree
 680 builtin_function (const char *name,
 681                   tree type,
 682                   int function_code,
 683                   enum built_in_class class,
 684                   const char *library_name,
 685                   tree attrs ATTRIBUTE_UNUSED)
 686 {
 687   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 688   DECL_EXTERNAL (decl) = 1;
 689   TREE_PUBLIC (decl) = 1;
 690   if (library_name)
 691     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
 692   make_decl_rtl (decl);
 693   pushdecl (decl);
 694   DECL_BUILT_IN_CLASS (decl) = class;
 695   DECL_FUNCTION_CODE (decl) = function_code;
 696   return decl;
 697 }
 698
 699
 700 static void
 701 gfc_define_builtin (const char * name,
 702                     tree type,
 703                     int code,
 704                     const char * library_name,
 705                     bool const_p)
 706 {
 707   tree decl;
 708
 709   decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
 710                            library_name, NULL_TREE);
 711   if (const_p)
 712     TREE_READONLY (decl) = 1;
 713
 714   built_in_decls[code] = decl;
 715   implicit_built_in_decls[code] = decl;
 716 }
 717
 718
 719 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 720     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 721                         BUILT_IN_ ## code, name, true); \
 722     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 723                         BUILT_IN_ ## code ## F, name "f", true);
 724
 725 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 726     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 727
 728 /* The middle-end is missing builtins for some complex math functions, so
 729    we don't use them yet.  */
 730 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 731     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 732 /*    DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)*/
 733
 734
 735 /* Create function types for builtin functions.  */
 736
 737 static void
 738 build_builtin_fntypes (tree * fntype, tree type)
 739 {
 740   tree tmp;
 741
 742   /* type (*) (type) */
 743   tmp = tree_cons (NULL_TREE, float_type_node, void_list_node);
 744   fntype[0] = build_function_type (type, tmp);
 745   /* type (*) (type, type) */
 746   tmp = tree_cons (NULL_TREE, float_type_node, tmp);
 747   fntype[1] = build_function_type (type, tmp);
 748   /* type (*) (int, type) */
 749   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 750   tmp = tree_cons (NULL_TREE, type, tmp);
 751   fntype[2] = build_function_type (type, tmp);
 752 }
 753
 754
 755 /* Initialisation of builtin function nodes.  */
 756
 757 static void
 758 gfc_init_builtin_functions (void)
 759 {
 760   tree mfunc_float[3];
 761   tree mfunc_double[3];
 762   tree mfunc_cfloat[3];
 763   tree mfunc_cdouble[3];
 764   tree func_cfloat_float;
 765   tree func_cdouble_double;
 766   tree ftype;
 767   tree tmp;
 768
 769   build_builtin_fntypes (mfunc_float, float_type_node);
 770   build_builtin_fntypes (mfunc_double, double_type_node);
 771   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 772   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 773
 774   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 775   func_cfloat_float = build_function_type (float_type_node, tmp);
 776
 777   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 778   func_cdouble_double = build_function_type (double_type_node, tmp);
 779
 780 #include "mathbuiltins.def"
 781
 782   /* We define these seperately as the fortran versions have different
 783      semantics (they return an integer type) */
 784   gfc_define_builtin ("__builtin_floor", mfunc_double[0],
 785                       BUILT_IN_FLOOR, "floor", true);
 786   gfc_define_builtin ("__builtin_floorf", mfunc_float[0],
 787                       BUILT_IN_FLOORF, "floorf", true);
 788   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 789                       BUILT_IN_ROUND, "round", true);
 790   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 791                       BUILT_IN_ROUNDF, "roundf", true);
 792
 793   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 794                       BUILT_IN_CABS, "cabs", true);
 795   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 796                       BUILT_IN_CABSF, "cabsf", true);
 797
 798
 799   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 800                       BUILT_IN_COPYSIGN, "copysign", true);
 801   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 802                       BUILT_IN_COPYSIGNF, "copysignf", true);
 803
 804   /* These are used to implement the ** operator.  */
 805   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 806                       BUILT_IN_POW, "pow", true);
 807   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 808                       BUILT_IN_POWF, "powf", true);
 809
 810   /* Other builtin functions we use.  */
 811
 812   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 813   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 814   ftype = build_function_type (long_integer_type_node, tmp);
 815   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 816                       "__builtin_expect", true);
 817
 818   tmp = tree_cons (NULL_TREE, size_type_node, void_list_node);
 819   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 820   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 821   ftype = build_function_type (pvoid_type_node, tmp);
 822   gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY,
 823                       "memcpy", false);
 824
 825   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 826   ftype = build_function_type (integer_type_node, tmp);
 827   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true);
 828
 829   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 830   ftype = build_function_type (integer_type_node, tmp);
 831   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true);
 832
 833   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
 834   ftype = build_function_type (integer_type_node, tmp);
 835   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true);
 836
 837   tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
 838   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 839   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 840   ftype = build_function_type (void_type_node, tmp);
 841   gfc_define_builtin ("__builtin_init_trampoline", ftype,
 842                       BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false);
 843
 844   tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
 845   ftype = build_function_type (pvoid_type_node, tmp);
 846   gfc_define_builtin ("__builtin_adjust_trampoline", ftype,
 847                       BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true);
 848
 849   /* The stack_save, stack_restore, and alloca builtins aren't used directly.
 850      They are inserted during gimplification to implement variable sized
 851      stack allocation.  */
 852
 853   ftype = build_function_type (pvoid_type_node, void_list_node);
 854   gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE,
 855                       "stack_save", false);
 856
 857   tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
 858   ftype = build_function_type (void_type_node, tmp);
 859   gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE,
 860                       "stack_restore", false);
 861
 862   tmp = tree_cons (NULL_TREE, size_type_node, void_list_node);
 863   ftype = build_function_type (pvoid_type_node, tmp);
 864   gfc_define_builtin ("__builtin_alloca", ftype, BUILT_IN_ALLOCA,
 865                       "alloca", false);
 866 }
 867
 868 #undef DEFINE_MATH_BUILTIN_C
 869 #undef DEFINE_MATH_BUILTIN
 870
 871 #include "gt-fortran-f95-lang.h"
 872 #include "gtype-fortran.h"