gcc/fortran/f95-lang.c

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