gcc/fortran/f95-lang.c

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