gcc/fortran/f95-lang.c

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