gcc/fortran/f95-lang.c

   1 /* gfortran backend interface
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
   3    Free Software Foundation, 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 static HOST_WIDE_INT gfc_get_alias_set (tree);
 103
 104 #undef LANG_HOOKS_NAME
 105 #undef LANG_HOOKS_INIT
 106 #undef LANG_HOOKS_FINISH
 107 #undef LANG_HOOKS_INIT_OPTIONS
 108 #undef LANG_HOOKS_HANDLE_OPTION
 109 #undef LANG_HOOKS_POST_OPTIONS
 110 #undef LANG_HOOKS_PRINT_IDENTIFIER
 111 #undef LANG_HOOKS_PARSE_FILE
 112 #undef LANG_HOOKS_MARK_ADDRESSABLE
 113 #undef LANG_HOOKS_TYPE_FOR_MODE
 114 #undef LANG_HOOKS_TYPE_FOR_SIZE
 115 #undef LANG_HOOKS_UNSIGNED_TYPE
 116 #undef LANG_HOOKS_SIGNED_TYPE
 117 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 118 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 119 #undef LANG_HOOKS_CLEAR_BINDING_STACK
 120 #undef LANG_HOOKS_GET_ALIAS_SET
 121 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
 122 #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
 123 #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
 124 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 125 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 126
 127 /* Define lang hooks.  */
 128 #define LANG_HOOKS_NAME                 "GNU F95"
 129 #define LANG_HOOKS_INIT                 gfc_init
 130 #define LANG_HOOKS_FINISH               gfc_finish
 131 #define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
 132 #define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
 133 #define LANG_HOOKS_POST_OPTIONS         gfc_post_options
 134 #define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
 135 #define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
 136 #define LANG_HOOKS_MARK_ADDRESSABLE        gfc_mark_addressable
 137 #define LANG_HOOKS_TYPE_FOR_MODE           gfc_type_for_mode
 138 #define LANG_HOOKS_TYPE_FOR_SIZE           gfc_type_for_size
 139 #define LANG_HOOKS_UNSIGNED_TYPE           gfc_unsigned_type
 140 #define LANG_HOOKS_SIGNED_TYPE             gfc_signed_type
 141 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
 142 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
 143 #define LANG_HOOKS_CLEAR_BINDING_STACK     gfc_clear_binding_stack
 144 #define LANG_HOOKS_GET_ALIAS_SET           gfc_get_alias_set
 145 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE   gfc_omp_privatize_by_reference
 146 #define LANG_HOOKS_OMP_PREDETERMINED_SHARING    gfc_omp_predetermined_sharing
 147 #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR     gfc_omp_disregard_value_expr
 148 #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE     gfc_omp_private_debug_clause
 149 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
 150   gfc_omp_firstprivatize_type_sizes
 151
 152 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 153
 154 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 155    that have names.  Here so we can clear out their names' definitions
 156    at the end of the function.  */
 157
 158 /* Tree code classes.  */
 159
 160 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 161
 162 const enum tree_code_class tree_code_type[] = {
 163 #include "tree.def"
 164 };
 165 #undef DEFTREECODE
 166
 167 /* Table indexed by tree code giving number of expression
 168    operands beyond the fixed part of the node structure.
 169    Not used for types or decls.  */
 170
 171 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 172
 173 const unsigned char tree_code_length[] = {
 174 #include "tree.def"
 175 };
 176 #undef DEFTREECODE
 177
 178 /* Names of tree components.
 179    Used for printing out the tree and error messages.  */
 180 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 181
 182 const char *const tree_code_name[] = {
 183 #include "tree.def"
 184 };
 185 #undef DEFTREECODE
 186
 187
 188 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 189
 190 /* A chain of binding_level structures awaiting reuse.  */
 191
 192 static GTY(()) struct binding_level *free_binding_level;
 193
 194 /* The elements of `ridpointers' are identifier nodes
 195    for the reserved type names and storage classes.
 196    It is indexed by a RID_... value.  */
 197 tree *ridpointers = NULL;
 198
 199 /* language-specific flags.  */
 200
 201 static void
 202 gfc_expand_function (tree fndecl)
 203 {
 204   tree t;
 205
 206   if (DECL_INITIAL (fndecl)
 207       && BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl)))
 208     {
 209       /* Local static equivalenced variables are never seen by
 210          check_global_declarations, so we need to output debug
 211          info by hand.  */
 212
 213       t = BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl));
 214       for (t = BLOCK_VARS (t); t; t = TREE_CHAIN (t))
 215         if (TREE_CODE (t) == VAR_DECL && DECL_HAS_VALUE_EXPR_P (t)
 216             && TREE_STATIC (t))
 217           {
 218             tree expr = DECL_VALUE_EXPR (t);
 219
 220             if (TREE_CODE (expr) == COMPONENT_REF
 221                 && TREE_CODE (TREE_OPERAND (expr, 0)) == VAR_DECL
 222                 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0)))
 223                    == UNION_TYPE
 224                 && cgraph_varpool_node (TREE_OPERAND (expr, 0))->needed
 225                 && errorcount == 0 && sorrycount == 0)
 226               {
 227                 timevar_push (TV_SYMOUT);
 228                 (*debug_hooks->global_decl) (t);
 229                 timevar_pop (TV_SYMOUT);
 230               }
 231           }
 232     }
 233
 234   tree_rest_of_compilation (fndecl);
 235 }
 236 \f
 237
 238 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
 239    or validate its data type for an `if' or `while' statement or ?..: exp.
 240
 241    This preparation consists of taking the ordinary
 242    representation of an expression expr and producing a valid tree
 243    boolean expression describing whether expr is nonzero.  We could
 244    simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
 245    but we optimize comparisons, &&, ||, and !.
 246
 247    The resulting type should always be `boolean_type_node'.
 248    This is much simpler than the corresponding C version because we have a
 249    distinct boolean type.  */
 250
 251 tree
 252 gfc_truthvalue_conversion (tree expr)
 253 {
 254   switch (TREE_CODE (TREE_TYPE (expr)))
 255     {
 256     case BOOLEAN_TYPE:
 257       if (TREE_TYPE (expr) == boolean_type_node)
 258         return expr;
 259       else if (COMPARISON_CLASS_P (expr))
 260         {
 261           TREE_TYPE (expr) = boolean_type_node;
 262           return expr;
 263         }
 264       else if (TREE_CODE (expr) == NOP_EXPR)
 265         return build1 (NOP_EXPR, boolean_type_node,
 266                        TREE_OPERAND (expr, 0));
 267       else
 268         return build1 (NOP_EXPR, boolean_type_node, expr);
 269
 270     case INTEGER_TYPE:
 271       if (TREE_CODE (expr) == INTEGER_CST)
 272         return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
 273       else
 274         return build2 (NE_EXPR, boolean_type_node, expr,
 275                        build_int_cst (TREE_TYPE (expr), 0));
 276
 277     default:
 278       internal_error ("Unexpected type in truthvalue_conversion");
 279     }
 280 }
 281
 282 static void
 283 gfc_create_decls (void)
 284 {
 285   /* GCC builtins.  */
 286   gfc_init_builtin_functions ();
 287
 288   /* Runtime/IO library functions.  */
 289   gfc_build_builtin_function_decls ();
 290
 291   gfc_init_constants ();
 292 }
 293
 294 static void
 295 gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 296 {
 297   int errors;
 298   int warnings;
 299
 300   gfc_create_decls ();
 301   gfc_parse_file ();
 302   gfc_generate_constructors ();
 303
 304   cgraph_finalize_compilation_unit ();
 305   cgraph_optimize ();
 306
 307   /* Tell the frontent about any errors.  */
 308   gfc_get_errors (&warnings, &errors);
 309   errorcount += errors;
 310   warningcount += warnings;
 311 }
 312 \f
 313 /* Initialize everything.  */
 314
 315 static bool
 316 gfc_init (void)
 317 {
 318 #ifdef USE_MAPPED_LOCATION
 319   linemap_add (&line_table, LC_ENTER, false, gfc_source_file, 1);
 320   linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
 321 #endif
 322
 323   /* First initialize the backend.  */
 324   gfc_init_decl_processing ();
 325   gfc_static_ctors = NULL_TREE;
 326
 327   /* Then the frontend.  */
 328   gfc_init_1 ();
 329
 330   if (gfc_new_file () != SUCCESS)
 331     fatal_error ("can't open input file: %s", gfc_source_file);
 332   return true;
 333 }
 334
 335
 336 static void
 337 gfc_finish (void)
 338 {
 339   gfc_done_1 ();
 340   gfc_release_include_path ();
 341   return;
 342 }
 343
 344 static void
 345 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 346                       tree node ATTRIBUTE_UNUSED,
 347                       int indent ATTRIBUTE_UNUSED)
 348 {
 349   return;
 350 }
 351 \f
 352
 353 /* These functions and variables deal with binding contours.  We only
 354    need these functions for the list of PARM_DECLs, but we leave the
 355    functions more general; these are a simplified version of the
 356    functions from GNAT.  */
 357
 358 /* For each binding contour we allocate a binding_level structure which records
 359    the entities defined or declared in that contour. Contours include:
 360
 361         the global one
 362         one for each subprogram definition
 363         one for each compound statement (declare block)
 364
 365    Binding contours are used to create GCC tree BLOCK nodes.  */
 366
 367 struct binding_level
 368 GTY(())
 369 {
 370   /* A chain of ..._DECL nodes for all variables, constants, functions,
 371      parameters and type declarations.  These ..._DECL nodes are chained
 372      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 373      in the reverse of the order supplied to be compatible with the
 374      back-end.  */
 375   tree names;
 376   /* For each level (except the global one), a chain of BLOCK nodes for all
 377      the levels that were entered and exited one level down from this one.  */
 378   tree blocks;
 379   /* The binding level containing this one (the enclosing binding level).  */
 380   struct binding_level *level_chain;
 381 };
 382
 383 /* The binding level currently in effect.  */
 384 static GTY(()) struct binding_level *current_binding_level = NULL;
 385
 386 /* The outermost binding level. This binding level is created when the
 387    compiler is started and it will exist through the entire compilation.  */
 388 static GTY(()) struct binding_level *global_binding_level;
 389
 390 /* Binding level structures are initialized by copying this one.  */
 391 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 392 \f
 393 /* Return nonzero if we are currently in the global binding level.  */
 394
 395 int
 396 global_bindings_p (void)
 397 {
 398   return current_binding_level == global_binding_level ? -1 : 0;
 399 }
 400
 401 tree
 402 getdecls (void)
 403 {
 404   return current_binding_level->names;
 405 }
 406
 407 /* Enter a new binding level. The input parameter is ignored, but has to be
 408    specified for back-end compatibility.  */
 409
 410 void
 411 pushlevel (int ignore ATTRIBUTE_UNUSED)
 412 {
 413   struct binding_level *newlevel
 414     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 415
 416   *newlevel = clear_binding_level;
 417
 418   /* Add this level to the front of the chain (stack) of levels that are
 419      active.  */
 420   newlevel->level_chain = current_binding_level;
 421   current_binding_level = newlevel;
 422 }
 423
 424 /* Exit a binding level.
 425    Pop the level off, and restore the state of the identifier-decl mappings
 426    that were in effect when this level was entered.
 427
 428    If KEEP is nonzero, this level had explicit declarations, so
 429    and create a "block" (a BLOCK node) for the level
 430    to record its declarations and subblocks for symbol table output.
 431
 432    If FUNCTIONBODY is nonzero, this level is the body of a function,
 433    so create a block as if KEEP were set and also clear out all
 434    label names.
 435
 436    If REVERSE is nonzero, reverse the order of decls before putting
 437    them into the BLOCK.  */
 438
 439 tree
 440 poplevel (int keep, int reverse, int functionbody)
 441 {
 442   /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
 443      binding level that we are about to exit and which is returned by this
 444      routine.  */
 445   tree block_node = NULL_TREE;
 446   tree decl_chain;
 447   tree subblock_chain = current_binding_level->blocks;
 448   tree subblock_node;
 449
 450   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 451      nodes chained through the `names' field of current_binding_level are in
 452      reverse order except for PARM_DECL node, which are explicitly stored in
 453      the right order.  */
 454   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 455     : current_binding_level->names;
 456
 457   /* If there were any declarations in the current binding level, or if this
 458      binding level is a function body, or if there are any nested blocks then
 459      create a BLOCK node to record them for the life of this function.  */
 460   if (keep || functionbody)
 461     block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
 462
 463   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 464   for (subblock_node = subblock_chain; subblock_node;
 465        subblock_node = TREE_CHAIN (subblock_node))
 466     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 467
 468   /* Clear out the meanings of the local variables of this level.  */
 469
 470   for (subblock_node = decl_chain; subblock_node;
 471        subblock_node = TREE_CHAIN (subblock_node))
 472     if (DECL_NAME (subblock_node) != 0)
 473       /* If the identifier was used or addressed via a local extern decl,
 474          don't forget that fact.  */
 475       if (DECL_EXTERNAL (subblock_node))
 476         {
 477           if (TREE_USED (subblock_node))
 478             TREE_USED (DECL_NAME (subblock_node)) = 1;
 479           if (TREE_ADDRESSABLE (subblock_node))
 480             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 481         }
 482
 483   /* Pop the current level.  */
 484   current_binding_level = current_binding_level->level_chain;
 485
 486   if (functionbody)
 487     {
 488       /* This is the top level block of a function. The ..._DECL chain stored
 489          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 490          leave them in the BLOCK because they are found in the FUNCTION_DECL
 491          instead.  */
 492       DECL_INITIAL (current_function_decl) = block_node;
 493       BLOCK_VARS (block_node) = 0;
 494     }
 495   else if (block_node)
 496     {
 497       current_binding_level->blocks
 498         = chainon (current_binding_level->blocks, block_node);
 499     }
 500
 501   /* If we did not make a block for the level just exited, any blocks made for
 502      inner levels (since they cannot be recorded as subblocks in that level)
 503      must be carried forward so they will later become subblocks of something
 504      else.  */
 505   else if (subblock_chain)
 506     current_binding_level->blocks
 507       = chainon (current_binding_level->blocks, subblock_chain);
 508   if (block_node)
 509     TREE_USED (block_node) = 1;
 510
 511   return block_node;
 512 }
 513 \f
 514 /* Insert BLOCK at the end of the list of subblocks of the
 515    current binding level.  This is used when a BIND_EXPR is expanded,
 516    to handle the BLOCK node inside the BIND_EXPR.  */
 517
 518 void
 519 insert_block (tree block)
 520 {
 521   TREE_USED (block) = 1;
 522   current_binding_level->blocks
 523     = chainon (current_binding_level->blocks, block);
 524 }
 525
 526 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 527    Returns the ..._DECL node.  */
 528
 529 tree
 530 pushdecl (tree decl)
 531 {
 532   /* External objects aren't nested, other objects may be.  */
 533   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 534     DECL_CONTEXT (decl) = 0;
 535   else
 536     DECL_CONTEXT (decl) = current_function_decl;
 537
 538   /* Put the declaration on the list.  The list of declarations is in reverse
 539      order. The list will be reversed later if necessary.  This needs to be
 540      this way for compatibility with the back-end.  */
 541
 542   TREE_CHAIN (decl) = current_binding_level->names;
 543   current_binding_level->names = decl;
 544
 545   /* For the declaration of a type, set its name if it is not already set.  */
 546
 547   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 548     {
 549       if (DECL_SOURCE_LINE (decl) == 0)
 550         TYPE_NAME (TREE_TYPE (decl)) = decl;
 551       else
 552         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 553     }
 554
 555   return decl;
 556 }
 557
 558
 559 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 560
 561 tree
 562 pushdecl_top_level (tree x)
 563 {
 564   tree t;
 565   struct binding_level *b = current_binding_level;
 566
 567   current_binding_level = global_binding_level;
 568   t = pushdecl (x);
 569   current_binding_level = b;
 570   return t;
 571 }
 572
 573
 574 /* Clear the binding stack.  */
 575 static void
 576 gfc_clear_binding_stack (void)
 577 {
 578   while (!global_bindings_p ())
 579     poplevel (0, 0, 0);
 580 }
 581
 582
 583 #ifndef CHAR_TYPE_SIZE
 584 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 585 #endif
 586
 587 #ifndef INT_TYPE_SIZE
 588 #define INT_TYPE_SIZE BITS_PER_WORD
 589 #endif
 590
 591 #undef SIZE_TYPE
 592 #define SIZE_TYPE "long unsigned int"
 593
 594 /* Create tree nodes for the basic scalar types of Fortran 95,
 595    and some nodes representing standard constants (0, 1, (void *) 0).
 596    Initialize the global binding level.
 597    Make definitions for built-in primitive functions.  */
 598 static void
 599 gfc_init_decl_processing (void)
 600 {
 601   current_function_decl = NULL;
 602   current_binding_level = NULL_BINDING_LEVEL;
 603   free_binding_level = NULL_BINDING_LEVEL;
 604
 605   /* Make the binding_level structure for global names. We move all
 606      variables that are in a COMMON block to this binding level.  */
 607   pushlevel (0);
 608   global_binding_level = current_binding_level;
 609
 610   /* Build common tree nodes. char_type_node is unsigned because we
 611      only use it for actual characters, not for INTEGER(1). Also, we
 612      want double_type_node to actually have double precision.  */
 613   build_common_tree_nodes (false, false);
 614   set_sizetype (long_unsigned_type_node);
 615   build_common_tree_nodes_2 (0);
 616   void_list_node = build_tree_list (NULL_TREE, void_type_node);
 617
 618   /* Set up F95 type nodes.  */
 619   gfc_init_kinds ();
 620   gfc_init_types ();
 621 }
 622
 623 /* Mark EXP saying that we need to be able to take the
 624    address of it; it should not be allocated in a register.
 625    In Fortran 95 this is only the case for variables with
 626    the TARGET attribute, but we implement it here for a
 627    likely future Cray pointer extension.
 628    Value is 1 if successful.  */
 629 /* TODO: Check/fix mark_addressable.  */
 630 bool
 631 gfc_mark_addressable (tree exp)
 632 {
 633   register tree x = exp;
 634   while (1)
 635     switch (TREE_CODE (x))
 636       {
 637       case COMPONENT_REF:
 638       case ADDR_EXPR:
 639       case ARRAY_REF:
 640       case REALPART_EXPR:
 641       case IMAGPART_EXPR:
 642         x = TREE_OPERAND (x, 0);
 643         break;
 644
 645       case CONSTRUCTOR:
 646         TREE_ADDRESSABLE (x) = 1;
 647         return true;
 648
 649       case VAR_DECL:
 650       case CONST_DECL:
 651       case PARM_DECL:
 652       case RESULT_DECL:
 653         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 654           {
 655             if (TREE_PUBLIC (x))
 656               {
 657                 error
 658                   ("global register variable %qs used in nested function",
 659                    IDENTIFIER_POINTER (DECL_NAME (x)));
 660                 return false;
 661               }
 662             pedwarn ("register variable %qs used in nested function",
 663                      IDENTIFIER_POINTER (DECL_NAME (x)));
 664           }
 665         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 666           {
 667             if (TREE_PUBLIC (x))
 668               {
 669                 error ("address of global register variable %qs requested",
 670                        IDENTIFIER_POINTER (DECL_NAME (x)));
 671                 return true;
 672               }
 673
 674 #if 0
 675             /* If we are making this addressable due to its having
 676                volatile components, give a different error message.  Also
 677                handle the case of an unnamed parameter by not trying
 678                to give the name.  */
 679
 680             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 681               {
 682                 error ("cannot put object with volatile field into register");
 683                 return false;
 684               }
 685 #endif
 686
 687             pedwarn ("address of register variable %qs requested",
 688                      IDENTIFIER_POINTER (DECL_NAME (x)));
 689           }
 690
 691         /* drops in */
 692       case FUNCTION_DECL:
 693         TREE_ADDRESSABLE (x) = 1;
 694
 695       default:
 696         return true;
 697       }
 698 }
 699
 700 /* Return the typed-based alias set for T, which may be an expression
 701    or a type.  Return -1 if we don't do anything special.  */
 702
 703 static HOST_WIDE_INT
 704 gfc_get_alias_set (tree t)
 705 {
 706   tree u;
 707
 708   /* Permit type-punning when accessing an EQUIVALENCEd variable or
 709      mixed type entry master's return value.  */
 710   for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
 711     if (TREE_CODE (u) == COMPONENT_REF
 712         && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
 713       return 0;
 714
 715   return -1;
 716 }
 717
 718 /* press the big red button - garbage (ggc) collection is on */
 719
 720 int ggc_p = 1;
 721
 722 /* Builtin function initialization.  */
 723
 724 /* Return a definition for a builtin function named NAME and whose data type
 725    is TYPE.  TYPE should be a function type with argument types.
 726    FUNCTION_CODE tells later passes how to compile calls to this function.
 727    See tree.h for its possible values.
 728
 729    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
 730    the name to be called if we can't opencode the function.  If
 731    ATTRS is nonzero, use that for the function's attribute list.  */
 732
 733 tree
 734 builtin_function (const char *name,
 735                   tree type,
 736                   int function_code,
 737                   enum built_in_class class,
 738                   const char *library_name,
 739                   tree attrs)
 740 {
 741   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 742   DECL_EXTERNAL (decl) = 1;
 743   TREE_PUBLIC (decl) = 1;
 744   if (library_name)
 745     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
 746   make_decl_rtl (decl);
 747   pushdecl (decl);
 748   DECL_BUILT_IN_CLASS (decl) = class;
 749   DECL_FUNCTION_CODE (decl) = function_code;
 750
 751   /* Possibly apply some default attributes to this built-in function.  */
 752   if (attrs)
 753     {
 754       /* FORNOW the only supported attribute is "const".  If others need
 755          to be supported then see the more general solution in procedure
 756          builtin_function in c-decl.c  */
 757       if (lookup_attribute ( "const", attrs ))
 758         TREE_READONLY (decl) = 1;
 759     }
 760
 761   return decl;
 762 }
 763
 764
 765 static void
 766 gfc_define_builtin (const char * name,
 767                     tree type,
 768                     int code,
 769                     const char * library_name,
 770                     bool const_p)
 771 {
 772   tree decl;
 773
 774   decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
 775                            library_name, NULL_TREE);
 776   if (const_p)
 777     TREE_READONLY (decl) = 1;
 778
 779   built_in_decls[code] = decl;
 780   implicit_built_in_decls[code] = decl;
 781 }
 782
 783
 784 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 785     gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
 786                        BUILT_IN_ ## code ## L, name "l", true); \
 787     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 788                         BUILT_IN_ ## code, name, true); \
 789     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 790                         BUILT_IN_ ## code ## F, name "f", true);
 791
 792 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 793     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 794
 795 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 796     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
 797     DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
 798
 799
 800 /* Create function types for builtin functions.  */
 801
 802 static void
 803 build_builtin_fntypes (tree * fntype, tree type)
 804 {
 805   tree tmp;
 806
 807   /* type (*) (type) */
 808   tmp = tree_cons (NULL_TREE, type, void_list_node);
 809   fntype[0] = build_function_type (type, tmp);
 810   /* type (*) (type, type) */
 811   tmp = tree_cons (NULL_TREE, type, tmp);
 812   fntype[1] = build_function_type (type, tmp);
 813   /* type (*) (int, type) */
 814   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 815   tmp = tree_cons (NULL_TREE, type, tmp);
 816   fntype[2] = build_function_type (type, tmp);
 817 }
 818
 819 static tree
 820 builtin_type_for_size (int size, bool unsignedp)
 821 {
 822   tree type = lang_hooks.types.type_for_size (size, unsignedp);
 823   return type ? type : error_mark_node;
 824 }
 825
 826 /* Initialization of builtin function nodes.  */
 827
 828 static void
 829 gfc_init_builtin_functions (void)
 830 {
 831   enum builtin_type
 832   {
 833 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
 834 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
 835 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
 836 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
 837 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
 838 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
 839 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
 840 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
 841 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
 842 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
 843 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
 844 #include "types.def"
 845 #undef DEF_PRIMITIVE_TYPE
 846 #undef DEF_FUNCTION_TYPE_0
 847 #undef DEF_FUNCTION_TYPE_1
 848 #undef DEF_FUNCTION_TYPE_2
 849 #undef DEF_FUNCTION_TYPE_3
 850 #undef DEF_FUNCTION_TYPE_4
 851 #undef DEF_FUNCTION_TYPE_5
 852 #undef DEF_FUNCTION_TYPE_6
 853 #undef DEF_FUNCTION_TYPE_7
 854 #undef DEF_FUNCTION_TYPE_VAR_0
 855 #undef DEF_POINTER_TYPE
 856     BT_LAST
 857   };
 858   typedef enum builtin_type builtin_type;
 859   enum
 860   {
 861     /* So far we need just these 2 attribute types.  */
 862     ATTR_NOTHROW_LIST,
 863     ATTR_CONST_NOTHROW_LIST
 864   };
 865
 866   tree mfunc_float[3];
 867   tree mfunc_double[3];
 868   tree mfunc_longdouble[3];
 869   tree mfunc_cfloat[3];
 870   tree mfunc_cdouble[3];
 871   tree mfunc_clongdouble[3];
 872   tree func_cfloat_float;
 873   tree func_cdouble_double;
 874   tree func_clongdouble_longdouble;
 875   tree ftype;
 876   tree tmp;
 877   tree builtin_types[(int) BT_LAST + 1];
 878
 879   build_builtin_fntypes (mfunc_float, float_type_node);
 880   build_builtin_fntypes (mfunc_double, double_type_node);
 881   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 882   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 883   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 884   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 885
 886   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 887   func_cfloat_float = build_function_type (float_type_node, tmp);
 888
 889   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 890   func_cdouble_double = build_function_type (double_type_node, tmp);
 891
 892   tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
 893   func_clongdouble_longdouble =
 894     build_function_type (long_double_type_node, tmp);
 895
 896 #include "mathbuiltins.def"
 897
 898   /* We define these separately as the fortran versions have different
 899      semantics (they return an integer type) */
 900   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 901                       BUILT_IN_ROUNDL, "roundl", true);
 902   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 903                       BUILT_IN_ROUND, "round", true);
 904   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 905                       BUILT_IN_ROUNDF, "roundf", true);
 906
 907   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 908                       BUILT_IN_TRUNCL, "truncl", true);
 909   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 910                       BUILT_IN_TRUNC, "trunc", true);
 911   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 912                       BUILT_IN_TRUNCF, "truncf", true);
 913
 914   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 915                       BUILT_IN_CABSL, "cabsl", true);
 916   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 917                       BUILT_IN_CABS, "cabs", true);
 918   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 919                       BUILT_IN_CABSF, "cabsf", true);
 920
 921   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 922                       BUILT_IN_COPYSIGNL, "copysignl", true);
 923   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 924                       BUILT_IN_COPYSIGN, "copysign", true);
 925   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 926                       BUILT_IN_COPYSIGNF, "copysignf", true);
 927
 928   /* These are used to implement the ** operator.  */
 929   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 930                       BUILT_IN_POWL, "powl", true);
 931   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 932                       BUILT_IN_POW, "pow", true);
 933   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 934                       BUILT_IN_POWF, "powf", true);
 935
 936   /* Other builtin functions we use.  */
 937
 938   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 939   ftype = build_function_type (integer_type_node, tmp);
 940   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
 941                       "__builtin_clz", true);
 942
 943   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 944   ftype = build_function_type (integer_type_node, tmp);
 945   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
 946                       "__builtin_clzl", true);
 947
 948   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
 949   ftype = build_function_type (integer_type_node, tmp);
 950   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
 951                       "__builtin_clzll", true);
 952
 953   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 954   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 955   ftype = build_function_type (long_integer_type_node, tmp);
 956   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 957                       "__builtin_expect", true);
 958
 959 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
 960   builtin_types[(int) ENUM] = VALUE;
 961 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN)               \
 962   builtin_types[(int) ENUM]                             \
 963     = build_function_type (builtin_types[(int) RETURN], \
 964                            void_list_node);
 965 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1)                         \
 966   builtin_types[(int) ENUM]                                             \
 967     = build_function_type (builtin_types[(int) RETURN],                 \
 968                            tree_cons (NULL_TREE,                        \
 969                                       builtin_types[(int) ARG1],        \
 970                                       void_list_node));
 971 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2)   \
 972   builtin_types[(int) ENUM]                             \
 973     = build_function_type                               \
 974       (builtin_types[(int) RETURN],                     \
 975        tree_cons (NULL_TREE,                            \
 976                   builtin_types[(int) ARG1],            \
 977                   tree_cons (NULL_TREE,                 \
 978                              builtin_types[(int) ARG2], \
 979                              void_list_node)));
 980 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3)              \
 981   builtin_types[(int) ENUM]                                              \
 982     = build_function_type                                                \
 983       (builtin_types[(int) RETURN],                                      \
 984        tree_cons (NULL_TREE,                                             \
 985                   builtin_types[(int) ARG1],                             \
 986                   tree_cons (NULL_TREE,                                  \
 987                              builtin_types[(int) ARG2],                  \
 988                              tree_cons (NULL_TREE,                       \
 989                                         builtin_types[(int) ARG3],       \
 990                                         void_list_node))));
 991 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)       \
 992   builtin_types[(int) ENUM]                                             \
 993     = build_function_type                                               \
 994       (builtin_types[(int) RETURN],                                     \
 995        tree_cons (NULL_TREE,                                            \
 996                   builtin_types[(int) ARG1],                            \
 997                   tree_cons (NULL_TREE,                                 \
 998                              builtin_types[(int) ARG2],                 \
 999                              tree_cons                                  \
1000                              (NULL_TREE,                                \
1001                               builtin_types[(int) ARG3],                \
1002                               tree_cons (NULL_TREE,                     \
1003                                          builtin_types[(int) ARG4],     \
1004                                          void_list_node)))));
1005 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
1006   builtin_types[(int) ENUM]                                             \
1007     = build_function_type                                               \
1008       (builtin_types[(int) RETURN],                                     \
1009        tree_cons (NULL_TREE,                                            \
1010                   builtin_types[(int) ARG1],                            \
1011                   tree_cons (NULL_TREE,                                 \
1012                              builtin_types[(int) ARG2],                 \
1013                              tree_cons                                  \
1014                              (NULL_TREE,                                \
1015                               builtin_types[(int) ARG3],                \
1016                               tree_cons (NULL_TREE,                     \
1017                                          builtin_types[(int) ARG4],     \
1018                                          tree_cons (NULL_TREE,          \
1019                                               builtin_types[(int) ARG5],\
1020                                               void_list_node))))));
1021 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1022                             ARG6)                                       \
1023   builtin_types[(int) ENUM]                                             \
1024     = build_function_type                                               \
1025       (builtin_types[(int) RETURN],                                     \
1026        tree_cons (NULL_TREE,                                            \
1027                   builtin_types[(int) ARG1],                            \
1028                   tree_cons (NULL_TREE,                                 \
1029                              builtin_types[(int) ARG2],                 \
1030                              tree_cons                                  \
1031                              (NULL_TREE,                                \
1032                               builtin_types[(int) ARG3],                \
1033                               tree_cons                                 \
1034                               (NULL_TREE,                               \
1035                                builtin_types[(int) ARG4],               \
1036                                tree_cons (NULL_TREE,                    \
1037                                          builtin_types[(int) ARG5],     \
1038                                          tree_cons (NULL_TREE,          \
1039                                               builtin_types[(int) ARG6],\
1040                                               void_list_node)))))));
1041 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1042                             ARG6, ARG7)                                 \
1043   builtin_types[(int) ENUM]                                             \
1044     = build_function_type                                               \
1045       (builtin_types[(int) RETURN],                                     \
1046        tree_cons (NULL_TREE,                                            \
1047                   builtin_types[(int) ARG1],                            \
1048                   tree_cons (NULL_TREE,                                 \
1049                              builtin_types[(int) ARG2],                 \
1050                              tree_cons                                  \
1051                              (NULL_TREE,                                \
1052                               builtin_types[(int) ARG3],                \
1053                               tree_cons                                 \
1054                               (NULL_TREE,                               \
1055                                builtin_types[(int) ARG4],               \
1056                                tree_cons (NULL_TREE,                    \
1057                                          builtin_types[(int) ARG5],     \
1058                                          tree_cons (NULL_TREE,          \
1059                                               builtin_types[(int) ARG6],\
1060                                          tree_cons (NULL_TREE,          \
1061                                               builtin_types[(int) ARG6], \
1062                                               void_list_node))))))));
1063 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN)                           \
1064   builtin_types[(int) ENUM]                                             \
1065     = build_function_type (builtin_types[(int) RETURN], NULL_TREE);
1066 #define DEF_POINTER_TYPE(ENUM, TYPE)                    \
1067   builtin_types[(int) ENUM]                             \
1068     = build_pointer_type (builtin_types[(int) TYPE]);
1069 #include "types.def"
1070 #undef DEF_PRIMITIVE_TYPE
1071 #undef DEF_FUNCTION_TYPE_1
1072 #undef DEF_FUNCTION_TYPE_2
1073 #undef DEF_FUNCTION_TYPE_3
1074 #undef DEF_FUNCTION_TYPE_4
1075 #undef DEF_FUNCTION_TYPE_5
1076 #undef DEF_FUNCTION_TYPE_6
1077 #undef DEF_FUNCTION_TYPE_VAR_0
1078 #undef DEF_POINTER_TYPE
1079   builtin_types[(int) BT_LAST] = NULL_TREE;
1080
1081   /* Initialize synchronization builtins.  */
1082 #undef DEF_SYNC_BUILTIN
1083 #define DEF_SYNC_BUILTIN(code, name, type, attr) \
1084     gfc_define_builtin (name, builtin_types[type], code, name, \
1085                         attr == ATTR_CONST_NOTHROW_LIST);
1086 #include "../sync-builtins.def"
1087 #undef DEF_SYNC_BUILTIN
1088
1089   if (gfc_option.flag_openmp)
1090     {
1091 #undef DEF_GOMP_BUILTIN
1092 #define DEF_GOMP_BUILTIN(code, name, type, attr) \
1093       gfc_define_builtin ("__builtin_" name, builtin_types[type], \
1094                           code, name, attr == ATTR_CONST_NOTHROW_LIST);
1095 #include "../omp-builtins.def"
1096 #undef DEF_GOMP_BUILTIN
1097     }
1098
1099   gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
1100                       BUILT_IN_TRAP, NULL, false);
1101   TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1;
1102
1103   build_common_builtin_nodes ();
1104   targetm.init_builtins ();
1105 }
1106
1107 #undef DEFINE_MATH_BUILTIN_C
1108 #undef DEFINE_MATH_BUILTIN
1109
1110 #include "gt-fortran-f95-lang.h"
1111 #include "gtype-fortran.h"