gcc/fortran/f95-lang.c

   1 /* G95 Backend interface
   2    Copyright (C) 2000, 2001, 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 /* f95-lang.c-- GCC backend interface stuff */
  23
  24 /* declare required prototypes: */
  25
  26 #include "config.h"
  27 #include "ansidecl.h"
  28 #include "system.h"
  29 #include "coretypes.h"
  30 #include "tree.h"
  31 #include "tree-gimple.h"
  32 #include "flags.h"
  33 #include "langhooks.h"
  34 #include "langhooks-def.h"
  35 #include "timevar.h"
  36 #include "tm.h"
  37 #include "function.h"
  38 #include "ggc.h"
  39 #include "toplev.h"
  40 #include "target.h"
  41 #include "debug.h"
  42 #include "diagnostic.h"
  43 #include "tree-dump.h"
  44 #include "cgraph.h"
  45
  46 #include "gfortran.h"
  47 #include "trans.h"
  48 #include "trans-types.h"
  49 #include "trans-const.h"
  50
  51 #include <assert.h>
  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 void set_block (tree);
 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_GIMPLE_BEFORE_INLINING
 125 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 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_GIMPLE_BEFORE_INLINING false
 144 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
 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 build (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   /* First initialize the backend.  */
 283   gfc_init_decl_processing ();
 284   gfc_static_ctors = NULL_TREE;
 285
 286   /* Then the frontend.  */
 287   gfc_init_1 ();
 288
 289   if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS)
 290     fatal_error ("can't open input file: %s", gfc_option.source);
 291   return true;
 292 }
 293
 294
 295 static void
 296 gfc_finish (void)
 297 {
 298   gfc_done_1 ();
 299   gfc_release_include_path ();
 300   return;
 301 }
 302
 303 static void
 304 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 305                       tree node ATTRIBUTE_UNUSED,
 306                       int indent ATTRIBUTE_UNUSED)
 307 {
 308   return;
 309 }
 310 \f
 311
 312 /* These functions and variables deal with binding contours.  We only
 313    need these functions for the list of PARM_DECLs, but we leave the
 314    functions more general; these are a simplified version of the
 315    functions from GNAT.  */
 316
 317 /* For each binding contour we allocate a binding_level structure which records
 318    the entities defined or declared in that contour. Contours include:
 319
 320         the global one
 321         one for each subprogram definition
 322         one for each compound statement (declare block)
 323
 324    Binding contours are used to create GCC tree BLOCK nodes.  */
 325
 326 struct binding_level
 327 GTY(())
 328 {
 329   /* A chain of ..._DECL nodes for all variables, constants, functions,
 330      parameters and type declarations.  These ..._DECL nodes are chained
 331      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 332      in the reverse of the order supplied to be compatible with the
 333      back-end.  */
 334   tree names;
 335   /* For each level (except the global one), a chain of BLOCK nodes for all
 336      the levels that were entered and exited one level down from this one.  */
 337   tree blocks;
 338   /* The back end may need, for its own internal processing, to create a BLOCK
 339      node. This field is set aside for this purpose. If this field is non-null
 340      when the level is popped, i.e. when poplevel is invoked, we will use such
 341      block instead of creating a new one from the 'names' field, that is the
 342      ..._DECL nodes accumulated so far.  Typically the routine 'pushlevel'
 343      will be called before setting this field, so that if the front-end had
 344      inserted ..._DECL nodes in the current block they will not be lost.   */
 345   tree block_created_by_back_end;
 346   /* The binding level containing this one (the enclosing binding level). */
 347   struct binding_level *level_chain;
 348 };
 349
 350 /* The binding level currently in effect.  */
 351 static GTY(()) struct binding_level *current_binding_level = NULL;
 352
 353 /* The outermost binding level. This binding level is created when the
 354    compiler is started and it will exist through the entire compilation.  */
 355 static GTY(()) struct binding_level *global_binding_level;
 356
 357 /* Binding level structures are initialized by copying this one.  */
 358 static struct binding_level clear_binding_level = { NULL, NULL, NULL, NULL };
 359 \f
 360 /* Return non-zero if we are currently in the global binding level.  */
 361
 362 int
 363 global_bindings_p (void)
 364 {
 365   return current_binding_level == global_binding_level ? -1 : 0;
 366 }
 367
 368 tree
 369 getdecls (void)
 370 {
 371   return current_binding_level->names;
 372 }
 373
 374 /* Enter a new binding level. The input parameter is ignored, but has to be
 375    specified for back-end compatibility.  */
 376
 377 void
 378 pushlevel (int ignore ATTRIBUTE_UNUSED)
 379 {
 380   struct binding_level *newlevel
 381     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 382
 383   *newlevel = clear_binding_level;
 384
 385   /* Add this level to the front of the chain (stack) of levels that are
 386      active.  */
 387   newlevel->level_chain = current_binding_level;
 388   current_binding_level = newlevel;
 389 }
 390
 391 /* Exit a binding level.
 392    Pop the level off, and restore the state of the identifier-decl mappings
 393    that were in effect when this level was entered.
 394
 395    If KEEP is nonzero, this level had explicit declarations, so
 396    and create a "block" (a BLOCK node) for the level
 397    to record its declarations and subblocks for symbol table output.
 398
 399    If FUNCTIONBODY is nonzero, this level is the body of a function,
 400    so create a block as if KEEP were set and also clear out all
 401    label names.
 402
 403    If REVERSE is nonzero, reverse the order of decls before putting
 404    them into the BLOCK.  */
 405
 406 tree
 407 poplevel (int keep, int reverse, int functionbody)
 408 {
 409   /* Points to a BLOCK tree node. This is the BLOCK node construted for the
 410      binding level that we are about to exit and which is returned by this
 411      routine.  */
 412   tree block_node = NULL_TREE;
 413   tree decl_chain;
 414   tree subblock_chain = current_binding_level->blocks;
 415   tree subblock_node;
 416   tree block_created_by_back_end;
 417
 418   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 419      nodes chained through the `names' field of current_binding_level are in
 420      reverse order except for PARM_DECL node, which are explicitely stored in
 421      the right order.  */
 422   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 423     : current_binding_level->names;
 424
 425   block_created_by_back_end =
 426     current_binding_level->block_created_by_back_end;
 427   if (block_created_by_back_end != 0)
 428     {
 429       block_node = block_created_by_back_end;
 430
 431       /* Check if we are about to discard some information that was gathered
 432          by the front-end. Nameley check if the back-end created a new block
 433          without calling pushlevel first. To understand why things are lost
 434          just look at the next case (i.e. no block created by back-end.  */
 435       if ((keep || functionbody) && (decl_chain || subblock_chain))
 436         abort ();
 437     }
 438
 439   /* If there were any declarations in the current binding level, or if this
 440      binding level is a function body, or if there are any nested blocks then
 441      create a BLOCK node to record them for the life of this function.  */
 442   else if (keep || functionbody)
 443     block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
 444
 445   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 446   for (subblock_node = subblock_chain; subblock_node;
 447        subblock_node = TREE_CHAIN (subblock_node))
 448     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 449
 450   /* Clear out the meanings of the local variables of this level.  */
 451
 452   for (subblock_node = decl_chain; subblock_node;
 453        subblock_node = TREE_CHAIN (subblock_node))
 454     if (DECL_NAME (subblock_node) != 0)
 455       /* If the identifier was used or addressed via a local extern decl,
 456          don't forget that fact.   */
 457       if (DECL_EXTERNAL (subblock_node))
 458         {
 459           if (TREE_USED (subblock_node))
 460             TREE_USED (DECL_NAME (subblock_node)) = 1;
 461           if (TREE_ADDRESSABLE (subblock_node))
 462             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 463         }
 464
 465   /* Pop the current level.  */
 466   current_binding_level = current_binding_level->level_chain;
 467
 468   if (functionbody)
 469     {
 470       /* This is the top level block of a function. The ..._DECL chain stored
 471          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 472          leave them in the BLOCK because they are found in the FUNCTION_DECL
 473          instead.  */
 474       DECL_INITIAL (current_function_decl) = block_node;
 475       BLOCK_VARS (block_node) = 0;
 476     }
 477   else if (block_node)
 478     {
 479       if (block_created_by_back_end == NULL)
 480         current_binding_level->blocks
 481           = chainon (current_binding_level->blocks, block_node);
 482     }
 483
 484   /* If we did not make a block for the level just exited, any blocks made for
 485      inner levels (since they cannot be recorded as subblocks in that level)
 486      must be carried forward so they will later become subblocks of something
 487      else.  */
 488   else if (subblock_chain)
 489     current_binding_level->blocks
 490       = chainon (current_binding_level->blocks, subblock_chain);
 491   if (block_node)
 492     TREE_USED (block_node) = 1;
 493
 494   return block_node;
 495 }
 496 \f
 497 /* Insert BLOCK at the end of the list of subblocks of the
 498    current binding level.  This is used when a BIND_EXPR is expanded,
 499    to handle the BLOCK node inside the BIND_EXPR.  */
 500
 501 void
 502 insert_block (tree block)
 503 {
 504   TREE_USED (block) = 1;
 505   current_binding_level->blocks
 506     = chainon (current_binding_level->blocks, block);
 507 }
 508
 509 /* Set the BLOCK node for the innermost scope
 510    (the one we are currently in).  */
 511
 512 void
 513 set_block (tree block)
 514 {
 515   current_binding_level->block_created_by_back_end = block;
 516 }
 517
 518 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 519    Returns the ..._DECL node. */
 520
 521 tree
 522 pushdecl (tree decl)
 523 {
 524   /* External objects aren't nested, other objects may be.  */
 525   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 526     DECL_CONTEXT (decl) = 0;
 527   else
 528     DECL_CONTEXT (decl) = current_function_decl;
 529
 530   /* Put the declaration on the list.  The list of declarations is in reverse
 531      order. The list will be reversed later if necessary.  This needs to be
 532      this way for compatibility with the back-end.  */
 533
 534   TREE_CHAIN (decl) = current_binding_level->names;
 535   current_binding_level->names = decl;
 536
 537   /* For the declartion of a type, set its name if it is not already set. */
 538
 539   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 540     {
 541       if (DECL_SOURCE_LINE (decl) == 0)
 542         TYPE_NAME (TREE_TYPE (decl)) = decl;
 543       else
 544         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 545     }
 546
 547   return decl;
 548 }
 549
 550
 551 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 552
 553 tree
 554 pushdecl_top_level (tree x)
 555 {
 556   tree t;
 557   struct binding_level *b = current_binding_level;
 558
 559   current_binding_level = global_binding_level;
 560   t = pushdecl (x);
 561   current_binding_level = b;
 562   return t;
 563 }
 564
 565
 566 #ifndef CHAR_TYPE_SIZE
 567 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 568 #endif
 569
 570 #ifndef INT_TYPE_SIZE
 571 #define INT_TYPE_SIZE BITS_PER_WORD
 572 #endif
 573
 574 #undef SIZE_TYPE
 575 #define SIZE_TYPE "long unsigned int"
 576
 577 /* Create tree nodes for the basic scalar types of Fortran 95,
 578    and some nodes representing standard constants (0, 1, (void *) 0).
 579    Initialize the global binding level.
 580    Make definitions for built-in primitive functions.  */
 581 static void
 582 gfc_init_decl_processing (void)
 583 {
 584   current_function_decl = NULL;
 585   named_labels = NULL;
 586   current_binding_level = NULL_BINDING_LEVEL;
 587   free_binding_level = NULL_BINDING_LEVEL;
 588
 589   /* Make the binding_level structure for global names. We move all
 590      variables that are in a COMMON block to this binding level.  */
 591   pushlevel (0);
 592   global_binding_level = current_binding_level;
 593
 594   /* Build common tree nodes. char_type_node is unsigned because we
 595      only use it for actual characters, not for INTEGER(1). Also, we
 596      want double_type_node to actually have double precision.   */
 597   build_common_tree_nodes (0);
 598   set_sizetype (long_unsigned_type_node);
 599   build_common_tree_nodes_2 (0);
 600
 601   /* Set up F95 type nodes.  */
 602   gfc_init_types ();
 603 }
 604
 605 /* Mark EXP saying that we need to be able to take the
 606    address of it; it should not be allocated in a register.
 607    In Fortran 95 this is only the case for variables with
 608    the TARGET attribute, but we implement it here for a
 609    likely future Cray pointer extension.
 610    Value is 1 if successful.  */
 611 /* TODO: Check/fix mark_addressable.  */
 612 bool
 613 gfc_mark_addressable (tree exp)
 614 {
 615   register tree x = exp;
 616   while (1)
 617     switch (TREE_CODE (x))
 618       {
 619       case COMPONENT_REF:
 620       case ADDR_EXPR:
 621       case ARRAY_REF:
 622       case REALPART_EXPR:
 623       case IMAGPART_EXPR:
 624         x = TREE_OPERAND (x, 0);
 625         break;
 626
 627       case CONSTRUCTOR:
 628         TREE_ADDRESSABLE (x) = 1;
 629         return true;
 630
 631       case VAR_DECL:
 632       case CONST_DECL:
 633       case PARM_DECL:
 634       case RESULT_DECL:
 635         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 636           {
 637             if (TREE_PUBLIC (x))
 638               {
 639                 error
 640                   ("global register variable `%s' used in nested function",
 641                    IDENTIFIER_POINTER (DECL_NAME (x)));
 642                 return false;
 643               }
 644             pedwarn ("register variable `%s' used in nested function",
 645                      IDENTIFIER_POINTER (DECL_NAME (x)));
 646           }
 647         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 648           {
 649             if (TREE_PUBLIC (x))
 650               {
 651                 error ("address of global register variable `%s' requested",
 652                        IDENTIFIER_POINTER (DECL_NAME (x)));
 653                 return true;
 654               }
 655
 656 #if 0
 657             /* If we are making this addressable due to its having
 658                volatile components, give a different error message.  Also
 659                handle the case of an unnamed parameter by not trying
 660                to give the name.  */
 661
 662             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 663               {
 664                 error ("cannot put object with volatile field into register");
 665                 return false;
 666               }
 667 #endif
 668
 669             pedwarn ("address of register variable `%s' requested",
 670                      IDENTIFIER_POINTER (DECL_NAME (x)));
 671           }
 672         put_var_into_stack (x, /*rescan=*/true);
 673
 674         /* drops in */
 675       case FUNCTION_DECL:
 676         TREE_ADDRESSABLE (x) = 1;
 677
 678       default:
 679         return true;
 680       }
 681 }
 682
 683 /* press the big red button - garbage (ggc) collection is on */
 684
 685 int ggc_p = 1;
 686
 687 /* Builtin function initialisation.  */
 688
 689 /* Return a definition for a builtin function named NAME and whose data type
 690    is TYPE.  TYPE should be a function type with argument types.
 691    FUNCTION_CODE tells later passes how to compile calls to this function.
 692    See tree.h for its possible values.
 693
 694    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
 695    the name to be called if we can't opencode the function.  If
 696    ATTRS is nonzero, use that for the function's attribute list.  */
 697
 698 tree
 699 builtin_function (const char *name,
 700                   tree type,
 701                   int function_code,
 702                   enum built_in_class class,
 703                   const char *library_name,
 704                   tree attrs ATTRIBUTE_UNUSED)
 705 {
 706   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 707   DECL_EXTERNAL (decl) = 1;
 708   TREE_PUBLIC (decl) = 1;
 709   if (library_name)
 710     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
 711   make_decl_rtl (decl, NULL);
 712   pushdecl (decl);
 713   DECL_BUILT_IN_CLASS (decl) = class;
 714   DECL_FUNCTION_CODE (decl) = function_code;
 715   return decl;
 716 }
 717
 718
 719 static void
 720 gfc_define_builtin (const char * name,
 721                     tree type,
 722                     int code,
 723                     const char * library_name,
 724                     bool const_p)
 725 {
 726   tree decl;
 727
 728   decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
 729                            library_name, NULL_TREE);
 730   if (const_p)
 731     TREE_READONLY (decl) = 1;
 732
 733   built_in_decls[code] = decl;
 734   implicit_built_in_decls[code] = decl;
 735 }
 736
 737
 738 #define DEFINE_MATH_BUILTIN(code, name, nargs) \
 739     gfc_define_builtin ("__builtin_" name, mfunc_double[nargs-1], \
 740                         BUILT_IN_ ## code, name, true); \
 741     gfc_define_builtin ("__builtin_" name "f", mfunc_float[nargs-1], \
 742                         BUILT_IN_ ## code ## F, name "f", true);
 743
 744 /* Initialisation of builtin function nodes.  */
 745 static void
 746 gfc_init_builtin_functions (void)
 747 {
 748   tree mfunc_float[2];
 749   tree mfunc_double[2];
 750   tree ftype;
 751   tree tmp;
 752   tree voidchain;
 753
 754   voidchain = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
 755
 756   tmp = tree_cons (NULL_TREE, float_type_node, voidchain);
 757   mfunc_float[0] = build_function_type (float_type_node, tmp);
 758   tmp = tree_cons (NULL_TREE, float_type_node, tmp);
 759   mfunc_float[1] = build_function_type (float_type_node, tmp);
 760
 761   tmp = tree_cons (NULL_TREE, double_type_node, voidchain);
 762   mfunc_double[0] = build_function_type (double_type_node, tmp);
 763   tmp = tree_cons (NULL_TREE, double_type_node, tmp);
 764   mfunc_double[1] = build_function_type (double_type_node, tmp);
 765
 766 #include "mathbuiltins.def"
 767
 768   /* We define these seperately as the fortran versions have different
 769      semantics (they return an integer type) */
 770   gfc_define_builtin ("__builtin_floor", mfunc_double[0],
 771                       BUILT_IN_FLOOR, "floor", true);
 772   gfc_define_builtin ("__builtin_floorf", mfunc_float[0],
 773                       BUILT_IN_FLOORF, "floorf", true);
 774   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 775                       BUILT_IN_ROUND, "round", true);
 776   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 777                       BUILT_IN_ROUNDF, "roundf", true);
 778
 779   /* Other builtin functions we use.  */
 780
 781   tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain);
 782   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 783   ftype = build_function_type (long_integer_type_node, tmp);
 784   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 785                       "__builtin_expect", true);
 786
 787   tmp = tree_cons (NULL_TREE, size_type_node, voidchain);
 788   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 789   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 790   ftype = build_function_type (pvoid_type_node, tmp);
 791   gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY,
 792                       "memcpy", false);
 793
 794   tmp = tree_cons (NULL_TREE, integer_type_node, voidchain);
 795   ftype = build_function_type (integer_type_node, tmp);
 796   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true);
 797
 798   tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain);
 799   ftype = build_function_type (integer_type_node, tmp);
 800   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true);
 801
 802   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, voidchain);
 803   ftype = build_function_type (integer_type_node, tmp);
 804   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true);
 805
 806   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
 807   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 808   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
 809   ftype = build_function_type (void_type_node, tmp);
 810   gfc_define_builtin ("__builtin_init_trampoline", ftype,
 811                       BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false);
 812
 813   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
 814   ftype = build_function_type (pvoid_type_node, tmp);
 815   gfc_define_builtin ("__builtin_adjust_trampoline", ftype,
 816                       BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true);
 817
 818   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
 819   tmp = tree_cons (NULL_TREE, size_type_node, voidchain);
 820   ftype = build_function_type (pvoid_type_node, tmp);
 821   gfc_define_builtin ("__builtin_stack_alloc", ftype, BUILT_IN_STACK_ALLOC,
 822                       "stack_alloc", false);
 823
 824   /* The stack_save and stack_restore builtins aren't used directly.  They
 825      are inserted during gimplification to implement stack_alloc calls.  */
 826   ftype = build_function_type (pvoid_type_node, voidchain);
 827   gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE,
 828                       "stack_save", false);
 829   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
 830   ftype = build_function_type (void_type_node, tmp);
 831   gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE,
 832                       "stack_restore", false);
 833 }
 834
 835 #undef DEFINE_MATH_BUILTIN
 836
 837 #include "gt-fortran-f95-lang.h"
 838 #include "gtype-fortran.h"