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
 572   /* Set up F95 type nodes.  */
 573   gfc_init_kinds ();
 574   gfc_init_types ();
 575 }
 576
 577 /* Mark EXP saying that we need to be able to take the
 578    address of it; it should not be allocated in a register.
 579    In Fortran 95 this is only the case for variables with
 580    the TARGET attribute, but we implement it here for a
 581    likely future Cray pointer extension.
 582    Value is 1 if successful.  */
 583 /* TODO: Check/fix mark_addressable.  */
 584 bool
 585 gfc_mark_addressable (tree exp)
 586 {
 587   register tree x = exp;
 588   while (1)
 589     switch (TREE_CODE (x))
 590       {
 591       case COMPONENT_REF:
 592       case ADDR_EXPR:
 593       case ARRAY_REF:
 594       case REALPART_EXPR:
 595       case IMAGPART_EXPR:
 596         x = TREE_OPERAND (x, 0);
 597         break;
 598
 599       case CONSTRUCTOR:
 600         TREE_ADDRESSABLE (x) = 1;
 601         return true;
 602
 603       case VAR_DECL:
 604       case CONST_DECL:
 605       case PARM_DECL:
 606       case RESULT_DECL:
 607         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 608           {
 609             if (TREE_PUBLIC (x))
 610               {
 611                 error
 612                   ("global register variable %qs used in nested function",
 613                    IDENTIFIER_POINTER (DECL_NAME (x)));
 614                 return false;
 615               }
 616             pedwarn ("register variable %qs used in nested function",
 617                      IDENTIFIER_POINTER (DECL_NAME (x)));
 618           }
 619         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 620           {
 621             if (TREE_PUBLIC (x))
 622               {
 623                 error ("address of global register variable %qs requested",
 624                        IDENTIFIER_POINTER (DECL_NAME (x)));
 625                 return true;
 626               }
 627
 628 #if 0
 629             /* If we are making this addressable due to its having
 630                volatile components, give a different error message.  Also
 631                handle the case of an unnamed parameter by not trying
 632                to give the name.  */
 633
 634             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 635               {
 636                 error ("cannot put object with volatile field into register");
 637                 return false;
 638               }
 639 #endif
 640
 641             pedwarn ("address of register variable %qs requested",
 642                      IDENTIFIER_POINTER (DECL_NAME (x)));
 643           }
 644
 645         /* drops in */
 646       case FUNCTION_DECL:
 647         TREE_ADDRESSABLE (x) = 1;
 648
 649       default:
 650         return true;
 651       }
 652 }
 653
 654 /* press the big red button - garbage (ggc) collection is on */
 655
 656 int ggc_p = 1;
 657
 658 /* Builtin function initialization.  */
 659
 660 /* Return a definition for a builtin function named NAME and whose data type
 661    is TYPE.  TYPE should be a function type with argument types.
 662    FUNCTION_CODE tells later passes how to compile calls to this function.
 663    See tree.h for its possible values.
 664
 665    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
 666    the name to be called if we can't opencode the function.  If
 667    ATTRS is nonzero, use that for the function's attribute list.  */
 668
 669 tree
 670 builtin_function (const char *name,
 671                   tree type,
 672                   int function_code,
 673                   enum built_in_class class,
 674                   const char *library_name,
 675                   tree attrs)
 676 {
 677   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 678   DECL_EXTERNAL (decl) = 1;
 679   TREE_PUBLIC (decl) = 1;
 680   if (library_name)
 681     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
 682   make_decl_rtl (decl);
 683   pushdecl (decl);
 684   DECL_BUILT_IN_CLASS (decl) = class;
 685   DECL_FUNCTION_CODE (decl) = function_code;
 686
 687   /* Possibly apply some default attributes to this built-in function.  */
 688   if (attrs)
 689     {
 690       /* FORNOW the only supported attribute is "const".  If others need
 691          to be supported then see the more general solution in procedure
 692          builtin_function in c-decl.c  */
 693       if (lookup_attribute ( "const", attrs ))
 694         TREE_READONLY (decl) = 1;
 695     }
 696
 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 "l", tbase##longdouble[argtype], \
 722                        BUILT_IN_ ## code ## L, name "l", true); \
 723     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 724                         BUILT_IN_ ## code, name, true); \
 725     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 726                         BUILT_IN_ ## code ## F, name "f", true);
 727
 728 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 729     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 730
 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_longdouble[3];
 764   tree mfunc_cfloat[3];
 765   tree mfunc_cdouble[3];
 766   tree mfunc_clongdouble[3];
 767   tree func_cfloat_float;
 768   tree func_cdouble_double;
 769   tree func_clongdouble_longdouble;
 770   tree ftype;
 771   tree tmp;
 772
 773   build_builtin_fntypes (mfunc_float, float_type_node);
 774   build_builtin_fntypes (mfunc_double, double_type_node);
 775   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 776   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 777   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 778   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 779
 780   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 781   func_cfloat_float = build_function_type (float_type_node, tmp);
 782
 783   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 784   func_cdouble_double = build_function_type (double_type_node, tmp);
 785
 786   tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
 787   func_clongdouble_longdouble =
 788     build_function_type (long_double_type_node, tmp);
 789
 790 #include "mathbuiltins.def"
 791
 792   /* We define these separately as the fortran versions have different
 793      semantics (they return an integer type) */
 794   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 795                       BUILT_IN_ROUNDL, "roundl", true);
 796   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 797                       BUILT_IN_ROUND, "round", true);
 798   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 799                       BUILT_IN_ROUNDF, "roundf", true);
 800
 801   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 802                       BUILT_IN_TRUNCL, "truncl", true);
 803   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 804                       BUILT_IN_TRUNC, "trunc", true);
 805   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 806                       BUILT_IN_TRUNCF, "truncf", true);
 807
 808   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 809                       BUILT_IN_CABSL, "cabsl", true);
 810   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 811                       BUILT_IN_CABS, "cabs", true);
 812   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 813                       BUILT_IN_CABSF, "cabsf", true);
 814
 815   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 816                       BUILT_IN_COPYSIGNL, "copysignl", true);
 817   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 818                       BUILT_IN_COPYSIGN, "copysign", true);
 819   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 820                       BUILT_IN_COPYSIGNF, "copysignf", true);
 821
 822   /* These are used to implement the ** operator.  */
 823   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 824                       BUILT_IN_POWL, "powl", true);
 825   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 826                       BUILT_IN_POW, "pow", true);
 827   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 828                       BUILT_IN_POWF, "powf", true);
 829
 830   /* Other builtin functions we use.  */
 831
 832   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 833   ftype = build_function_type (integer_type_node, tmp);
 834   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
 835                       "__builtin_clz", true);
 836
 837   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 838   ftype = build_function_type (integer_type_node, tmp);
 839   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
 840                       "__builtin_clzl", true);
 841
 842   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
 843   ftype = build_function_type (integer_type_node, tmp);
 844   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
 845                       "__builtin_clzll", true);
 846
 847   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 848   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 849   ftype = build_function_type (long_integer_type_node, tmp);
 850   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 851                       "__builtin_expect", true);
 852
 853   build_common_builtin_nodes ();
 854   targetm.init_builtins ();
 855 }
 856
 857 #undef DEFINE_MATH_BUILTIN_C
 858 #undef DEFINE_MATH_BUILTIN
 859
 860 #include "gt-fortran-f95-lang.h"
 861 #include "gtype-fortran.h"