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