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