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,
 261                        build_int_cst (TREE_TYPE (expr), 0));
 262
 263     default:
 264       internal_error ("Unexpected type in truthvalue_conversion");
 265     }
 266 }
 267
 268 static void
 269 gfc_create_decls (void)
 270 {
 271   /* GCC builtins.  */
 272   gfc_init_builtin_functions ();
 273
 274   /* Runtime/IO library functions.  */
 275   gfc_build_builtin_function_decls ();
 276
 277   gfc_init_constants ();
 278 }
 279
 280 static void
 281 gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 282 {
 283   int errors;
 284   int warnings;
 285
 286   gfc_create_decls ();
 287   gfc_parse_file ();
 288   gfc_generate_constructors ();
 289
 290   cgraph_finalize_compilation_unit ();
 291   cgraph_optimize ();
 292
 293   /* Tell the frontent about any errors.  */
 294   gfc_get_errors (&warnings, &errors);
 295   errorcount += errors;
 296   warningcount += warnings;
 297 }
 298 \f
 299 /* Initialize everything.  */
 300
 301 static bool
 302 gfc_init (void)
 303 {
 304 #ifdef USE_MAPPED_LOCATION
 305   linemap_add (&line_table, LC_ENTER, false, gfc_source_file, 1);
 306   linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
 307 #endif
 308
 309   /* First initialize the backend.  */
 310   gfc_init_decl_processing ();
 311   gfc_static_ctors = NULL_TREE;
 312
 313   /* Then the frontend.  */
 314   gfc_init_1 ();
 315
 316   if (gfc_new_file () != SUCCESS)
 317     fatal_error ("can't open input file: %s", gfc_source_file);
 318   return true;
 319 }
 320
 321
 322 static void
 323 gfc_finish (void)
 324 {
 325   gfc_done_1 ();
 326   gfc_release_include_path ();
 327   return;
 328 }
 329
 330 static void
 331 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 332                       tree node ATTRIBUTE_UNUSED,
 333                       int indent ATTRIBUTE_UNUSED)
 334 {
 335   return;
 336 }
 337 \f
 338
 339 /* These functions and variables deal with binding contours.  We only
 340    need these functions for the list of PARM_DECLs, but we leave the
 341    functions more general; these are a simplified version of the
 342    functions from GNAT.  */
 343
 344 /* For each binding contour we allocate a binding_level structure which records
 345    the entities defined or declared in that contour. Contours include:
 346
 347         the global one
 348         one for each subprogram definition
 349         one for each compound statement (declare block)
 350
 351    Binding contours are used to create GCC tree BLOCK nodes.  */
 352
 353 struct binding_level
 354 GTY(())
 355 {
 356   /* A chain of ..._DECL nodes for all variables, constants, functions,
 357      parameters and type declarations.  These ..._DECL nodes are chained
 358      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 359      in the reverse of the order supplied to be compatible with the
 360      back-end.  */
 361   tree names;
 362   /* For each level (except the global one), a chain of BLOCK nodes for all
 363      the levels that were entered and exited one level down from this one.  */
 364   tree blocks;
 365   /* The binding level containing this one (the enclosing binding level).  */
 366   struct binding_level *level_chain;
 367 };
 368
 369 /* The binding level currently in effect.  */
 370 static GTY(()) struct binding_level *current_binding_level = NULL;
 371
 372 /* The outermost binding level. This binding level is created when the
 373    compiler is started and it will exist through the entire compilation.  */
 374 static GTY(()) struct binding_level *global_binding_level;
 375
 376 /* Binding level structures are initialized by copying this one.  */
 377 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 378 \f
 379 /* Return nonzero if we are currently in the global binding level.  */
 380
 381 int
 382 global_bindings_p (void)
 383 {
 384   return current_binding_level == global_binding_level ? -1 : 0;
 385 }
 386
 387 tree
 388 getdecls (void)
 389 {
 390   return current_binding_level->names;
 391 }
 392
 393 /* Enter a new binding level. The input parameter is ignored, but has to be
 394    specified for back-end compatibility.  */
 395
 396 void
 397 pushlevel (int ignore ATTRIBUTE_UNUSED)
 398 {
 399   struct binding_level *newlevel
 400     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 401
 402   *newlevel = clear_binding_level;
 403
 404   /* Add this level to the front of the chain (stack) of levels that are
 405      active.  */
 406   newlevel->level_chain = current_binding_level;
 407   current_binding_level = newlevel;
 408 }
 409
 410 /* Exit a binding level.
 411    Pop the level off, and restore the state of the identifier-decl mappings
 412    that were in effect when this level was entered.
 413
 414    If KEEP is nonzero, this level had explicit declarations, so
 415    and create a "block" (a BLOCK node) for the level
 416    to record its declarations and subblocks for symbol table output.
 417
 418    If FUNCTIONBODY is nonzero, this level is the body of a function,
 419    so create a block as if KEEP were set and also clear out all
 420    label names.
 421
 422    If REVERSE is nonzero, reverse the order of decls before putting
 423    them into the BLOCK.  */
 424
 425 tree
 426 poplevel (int keep, int reverse, int functionbody)
 427 {
 428   /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
 429      binding level that we are about to exit and which is returned by this
 430      routine.  */
 431   tree block_node = NULL_TREE;
 432   tree decl_chain;
 433   tree subblock_chain = current_binding_level->blocks;
 434   tree subblock_node;
 435
 436   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 437      nodes chained through the `names' field of current_binding_level are in
 438      reverse order except for PARM_DECL node, which are explicitly stored in
 439      the right order.  */
 440   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 441     : current_binding_level->names;
 442
 443   /* If there were any declarations in the current binding level, or if this
 444      binding level is a function body, or if there are any nested blocks then
 445      create a BLOCK node to record them for the life of this function.  */
 446   if (keep || functionbody)
 447     block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
 448
 449   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 450   for (subblock_node = subblock_chain; subblock_node;
 451        subblock_node = TREE_CHAIN (subblock_node))
 452     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 453
 454   /* Clear out the meanings of the local variables of this level.  */
 455
 456   for (subblock_node = decl_chain; subblock_node;
 457        subblock_node = TREE_CHAIN (subblock_node))
 458     if (DECL_NAME (subblock_node) != 0)
 459       /* If the identifier was used or addressed via a local extern decl,
 460          don't forget that fact.  */
 461       if (DECL_EXTERNAL (subblock_node))
 462         {
 463           if (TREE_USED (subblock_node))
 464             TREE_USED (DECL_NAME (subblock_node)) = 1;
 465           if (TREE_ADDRESSABLE (subblock_node))
 466             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 467         }
 468
 469   /* Pop the current level.  */
 470   current_binding_level = current_binding_level->level_chain;
 471
 472   if (functionbody)
 473     {
 474       /* This is the top level block of a function. The ..._DECL chain stored
 475          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 476          leave them in the BLOCK because they are found in the FUNCTION_DECL
 477          instead.  */
 478       DECL_INITIAL (current_function_decl) = block_node;
 479       BLOCK_VARS (block_node) = 0;
 480     }
 481   else if (block_node)
 482     {
 483       current_binding_level->blocks
 484         = chainon (current_binding_level->blocks, block_node);
 485     }
 486
 487   /* If we did not make a block for the level just exited, any blocks made for
 488      inner levels (since they cannot be recorded as subblocks in that level)
 489      must be carried forward so they will later become subblocks of something
 490      else.  */
 491   else if (subblock_chain)
 492     current_binding_level->blocks
 493       = chainon (current_binding_level->blocks, subblock_chain);
 494   if (block_node)
 495     TREE_USED (block_node) = 1;
 496
 497   return block_node;
 498 }
 499 \f
 500 /* Insert BLOCK at the end of the list of subblocks of the
 501    current binding level.  This is used when a BIND_EXPR is expanded,
 502    to handle the BLOCK node inside the BIND_EXPR.  */
 503
 504 void
 505 insert_block (tree block)
 506 {
 507   TREE_USED (block) = 1;
 508   current_binding_level->blocks
 509     = chainon (current_binding_level->blocks, block);
 510 }
 511
 512 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 513    Returns the ..._DECL node.  */
 514
 515 tree
 516 pushdecl (tree decl)
 517 {
 518   /* External objects aren't nested, other objects may be.  */
 519   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 520     DECL_CONTEXT (decl) = 0;
 521   else
 522     DECL_CONTEXT (decl) = current_function_decl;
 523
 524   /* Put the declaration on the list.  The list of declarations is in reverse
 525      order. The list will be reversed later if necessary.  This needs to be
 526      this way for compatibility with the back-end.  */
 527
 528   TREE_CHAIN (decl) = current_binding_level->names;
 529   current_binding_level->names = decl;
 530
 531   /* For the declaration of a type, set its name if it is not already set.  */
 532
 533   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 534     {
 535       if (DECL_SOURCE_LINE (decl) == 0)
 536         TYPE_NAME (TREE_TYPE (decl)) = decl;
 537       else
 538         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 539     }
 540
 541   return decl;
 542 }
 543
 544
 545 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 546
 547 tree
 548 pushdecl_top_level (tree x)
 549 {
 550   tree t;
 551   struct binding_level *b = current_binding_level;
 552
 553   current_binding_level = global_binding_level;
 554   t = pushdecl (x);
 555   current_binding_level = b;
 556   return t;
 557 }
 558
 559
 560 /* Clear the binding stack.  */
 561 static void
 562 gfc_clear_binding_stack (void)
 563 {
 564   while (!global_bindings_p ())
 565     poplevel (0, 0, 0);
 566 }
 567
 568
 569 #ifndef CHAR_TYPE_SIZE
 570 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 571 #endif
 572
 573 #ifndef INT_TYPE_SIZE
 574 #define INT_TYPE_SIZE BITS_PER_WORD
 575 #endif
 576
 577 #undef SIZE_TYPE
 578 #define SIZE_TYPE "long unsigned int"
 579
 580 /* Create tree nodes for the basic scalar types of Fortran 95,
 581    and some nodes representing standard constants (0, 1, (void *) 0).
 582    Initialize the global binding level.
 583    Make definitions for built-in primitive functions.  */
 584 static void
 585 gfc_init_decl_processing (void)
 586 {
 587   current_function_decl = NULL;
 588   current_binding_level = NULL_BINDING_LEVEL;
 589   free_binding_level = NULL_BINDING_LEVEL;
 590
 591   /* Make the binding_level structure for global names. We move all
 592      variables that are in a COMMON block to this binding level.  */
 593   pushlevel (0);
 594   global_binding_level = current_binding_level;
 595
 596   /* Build common tree nodes. char_type_node is unsigned because we
 597      only use it for actual characters, not for INTEGER(1). Also, we
 598      want double_type_node to actually have double precision.  */
 599   build_common_tree_nodes (false, false);
 600   set_sizetype (long_unsigned_type_node);
 601   build_common_tree_nodes_2 (0);
 602   void_list_node = build_tree_list (NULL_TREE, void_type_node);
 603
 604   /* Set up F95 type nodes.  */
 605   gfc_init_kinds ();
 606   gfc_init_types ();
 607 }
 608
 609 /* Mark EXP saying that we need to be able to take the
 610    address of it; it should not be allocated in a register.
 611    In Fortran 95 this is only the case for variables with
 612    the TARGET attribute, but we implement it here for a
 613    likely future Cray pointer extension.
 614    Value is 1 if successful.  */
 615 /* TODO: Check/fix mark_addressable.  */
 616 bool
 617 gfc_mark_addressable (tree exp)
 618 {
 619   register tree x = exp;
 620   while (1)
 621     switch (TREE_CODE (x))
 622       {
 623       case COMPONENT_REF:
 624       case ADDR_EXPR:
 625       case ARRAY_REF:
 626       case REALPART_EXPR:
 627       case IMAGPART_EXPR:
 628         x = TREE_OPERAND (x, 0);
 629         break;
 630
 631       case CONSTRUCTOR:
 632         TREE_ADDRESSABLE (x) = 1;
 633         return true;
 634
 635       case VAR_DECL:
 636       case CONST_DECL:
 637       case PARM_DECL:
 638       case RESULT_DECL:
 639         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 640           {
 641             if (TREE_PUBLIC (x))
 642               {
 643                 error
 644                   ("global register variable %qs used in nested function",
 645                    IDENTIFIER_POINTER (DECL_NAME (x)));
 646                 return false;
 647               }
 648             pedwarn ("register variable %qs used in nested function",
 649                      IDENTIFIER_POINTER (DECL_NAME (x)));
 650           }
 651         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 652           {
 653             if (TREE_PUBLIC (x))
 654               {
 655                 error ("address of global register variable %qs requested",
 656                        IDENTIFIER_POINTER (DECL_NAME (x)));
 657                 return true;
 658               }
 659
 660 #if 0
 661             /* If we are making this addressable due to its having
 662                volatile components, give a different error message.  Also
 663                handle the case of an unnamed parameter by not trying
 664                to give the name.  */
 665
 666             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 667               {
 668                 error ("cannot put object with volatile field into register");
 669                 return false;
 670               }
 671 #endif
 672
 673             pedwarn ("address of register variable %qs requested",
 674                      IDENTIFIER_POINTER (DECL_NAME (x)));
 675           }
 676
 677         /* drops in */
 678       case FUNCTION_DECL:
 679         TREE_ADDRESSABLE (x) = 1;
 680
 681       default:
 682         return true;
 683       }
 684 }
 685
 686 /* press the big red button - garbage (ggc) collection is on */
 687
 688 int ggc_p = 1;
 689
 690 /* Builtin function initialization.  */
 691
 692 /* Return a definition for a builtin function named NAME and whose data type
 693    is TYPE.  TYPE should be a function type with argument types.
 694    FUNCTION_CODE tells later passes how to compile calls to this function.
 695    See tree.h for its possible values.
 696
 697    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
 698    the name to be called if we can't opencode the function.  If
 699    ATTRS is nonzero, use that for the function's attribute list.  */
 700
 701 tree
 702 builtin_function (const char *name,
 703                   tree type,
 704                   int function_code,
 705                   enum built_in_class class,
 706                   const char *library_name,
 707                   tree attrs)
 708 {
 709   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 710   DECL_EXTERNAL (decl) = 1;
 711   TREE_PUBLIC (decl) = 1;
 712   if (library_name)
 713     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
 714   make_decl_rtl (decl);
 715   pushdecl (decl);
 716   DECL_BUILT_IN_CLASS (decl) = class;
 717   DECL_FUNCTION_CODE (decl) = function_code;
 718
 719   /* Possibly apply some default attributes to this built-in function.  */
 720   if (attrs)
 721     {
 722       /* FORNOW the only supported attribute is "const".  If others need
 723          to be supported then see the more general solution in procedure
 724          builtin_function in c-decl.c  */
 725       if (lookup_attribute ( "const", attrs ))
 726         TREE_READONLY (decl) = 1;
 727     }
 728
 729   return decl;
 730 }
 731
 732
 733 static void
 734 gfc_define_builtin (const char * name,
 735                     tree type,
 736                     int code,
 737                     const char * library_name,
 738                     bool const_p)
 739 {
 740   tree decl;
 741
 742   decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
 743                            library_name, NULL_TREE);
 744   if (const_p)
 745     TREE_READONLY (decl) = 1;
 746
 747   built_in_decls[code] = decl;
 748   implicit_built_in_decls[code] = decl;
 749 }
 750
 751
 752 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 753     gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
 754                        BUILT_IN_ ## code ## L, name "l", true); \
 755     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 756                         BUILT_IN_ ## code, name, true); \
 757     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 758                         BUILT_IN_ ## code ## F, name "f", true);
 759
 760 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 761     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 762
 763 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 764     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
 765     DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
 766
 767
 768 /* Create function types for builtin functions.  */
 769
 770 static void
 771 build_builtin_fntypes (tree * fntype, tree type)
 772 {
 773   tree tmp;
 774
 775   /* type (*) (type) */
 776   tmp = tree_cons (NULL_TREE, type, void_list_node);
 777   fntype[0] = build_function_type (type, tmp);
 778   /* type (*) (type, type) */
 779   tmp = tree_cons (NULL_TREE, type, tmp);
 780   fntype[1] = build_function_type (type, tmp);
 781   /* type (*) (int, type) */
 782   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 783   tmp = tree_cons (NULL_TREE, type, tmp);
 784   fntype[2] = build_function_type (type, tmp);
 785 }
 786
 787
 788 /* Initialization of builtin function nodes.  */
 789
 790 static void
 791 gfc_init_builtin_functions (void)
 792 {
 793   tree mfunc_float[3];
 794   tree mfunc_double[3];
 795   tree mfunc_longdouble[3];
 796   tree mfunc_cfloat[3];
 797   tree mfunc_cdouble[3];
 798   tree mfunc_clongdouble[3];
 799   tree func_cfloat_float;
 800   tree func_cdouble_double;
 801   tree func_clongdouble_longdouble;
 802   tree ftype;
 803   tree tmp;
 804
 805   build_builtin_fntypes (mfunc_float, float_type_node);
 806   build_builtin_fntypes (mfunc_double, double_type_node);
 807   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 808   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 809   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 810   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 811
 812   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 813   func_cfloat_float = build_function_type (float_type_node, tmp);
 814
 815   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 816   func_cdouble_double = build_function_type (double_type_node, tmp);
 817
 818   tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
 819   func_clongdouble_longdouble =
 820     build_function_type (long_double_type_node, tmp);
 821
 822 #include "mathbuiltins.def"
 823
 824   /* We define these separately as the fortran versions have different
 825      semantics (they return an integer type) */
 826   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 827                       BUILT_IN_ROUNDL, "roundl", true);
 828   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 829                       BUILT_IN_ROUND, "round", true);
 830   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 831                       BUILT_IN_ROUNDF, "roundf", true);
 832
 833   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 834                       BUILT_IN_TRUNCL, "truncl", true);
 835   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 836                       BUILT_IN_TRUNC, "trunc", true);
 837   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 838                       BUILT_IN_TRUNCF, "truncf", true);
 839
 840   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 841                       BUILT_IN_CABSL, "cabsl", true);
 842   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 843                       BUILT_IN_CABS, "cabs", true);
 844   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 845                       BUILT_IN_CABSF, "cabsf", true);
 846
 847   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 848                       BUILT_IN_COPYSIGNL, "copysignl", true);
 849   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 850                       BUILT_IN_COPYSIGN, "copysign", true);
 851   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 852                       BUILT_IN_COPYSIGNF, "copysignf", true);
 853
 854   /* These are used to implement the ** operator.  */
 855   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 856                       BUILT_IN_POWL, "powl", true);
 857   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 858                       BUILT_IN_POW, "pow", true);
 859   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 860                       BUILT_IN_POWF, "powf", true);
 861
 862   /* Other builtin functions we use.  */
 863
 864   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 865   ftype = build_function_type (integer_type_node, tmp);
 866   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
 867                       "__builtin_clz", true);
 868
 869   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 870   ftype = build_function_type (integer_type_node, tmp);
 871   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
 872                       "__builtin_clzl", true);
 873
 874   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
 875   ftype = build_function_type (integer_type_node, tmp);
 876   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
 877                       "__builtin_clzll", true);
 878
 879   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 880   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 881   ftype = build_function_type (long_integer_type_node, tmp);
 882   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 883                       "__builtin_expect", true);
 884
 885   build_common_builtin_nodes ();
 886   targetm.init_builtins ();
 887 }
 888
 889 #undef DEFINE_MATH_BUILTIN_C
 890 #undef DEFINE_MATH_BUILTIN
 891
 892 #include "gt-fortran-f95-lang.h"
 893 #include "gtype-fortran.h"