gcc/fortran/f95-lang.c

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