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