gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 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 /* trans-decl.c -- Handling of backend function and variable decls, etc */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tree.h"
  29 #include "tree-dump.h"
  30 #include "tree-gimple.h"
  31 #include "ggc.h"
  32 #include "toplev.h"
  33 #include "tm.h"
  34 #include "target.h"
  35 #include "function.h"
  36 #include "flags.h"
  37 #include "cgraph.h"
  38 #include "gfortran.h"
  39 #include "trans.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "trans-const.h"
  43 #include "rtl.h"
  44 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  45 #include "trans-stmt.h"
  46
  47 #define MAX_LABEL_VALUE 99999
  48
  49
  50 /* Holds the result of the function if no result variable specified.  */
  51
  52 static GTY(()) tree current_fake_result_decl;
  53
  54 static GTY(()) tree current_function_return_label;
  55
  56
  57 /* Holds the variable DECLs for the current function.  */
  58
  59 static GTY(()) tree saved_function_decls;
  60 static GTY(()) tree saved_parent_function_decls;
  61
  62
  63 /* The namespace of the module we're currently generating.  Only used while
  64    outputting decls for module variables.  Do not rely on this being set.  */
  65
  66 static gfc_namespace *module_namespace;
  67
  68
  69 /* List of static constructor functions.  */
  70
  71 tree gfc_static_ctors;
  72
  73
  74 /* Function declarations for builtin library functions.  */
  75
  76 tree gfor_fndecl_internal_malloc;
  77 tree gfor_fndecl_internal_malloc64;
  78 tree gfor_fndecl_internal_realloc;
  79 tree gfor_fndecl_internal_realloc64;
  80 tree gfor_fndecl_internal_free;
  81 tree gfor_fndecl_allocate;
  82 tree gfor_fndecl_allocate64;
  83 tree gfor_fndecl_deallocate;
  84 tree gfor_fndecl_pause_numeric;
  85 tree gfor_fndecl_pause_string;
  86 tree gfor_fndecl_stop_numeric;
  87 tree gfor_fndecl_stop_string;
  88 tree gfor_fndecl_select_string;
  89 tree gfor_fndecl_runtime_error;
  90 tree gfor_fndecl_set_fpe;
  91 tree gfor_fndecl_set_std;
  92 tree gfor_fndecl_set_convert;
  93 tree gfor_fndecl_ctime;
  94 tree gfor_fndecl_fdate;
  95 tree gfor_fndecl_ttynam;
  96 tree gfor_fndecl_in_pack;
  97 tree gfor_fndecl_in_unpack;
  98 tree gfor_fndecl_associated;
  99
 100
 101 /* Math functions.  Many other math functions are handled in
 102    trans-intrinsic.c.  */
 103
 104 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 105 tree gfor_fndecl_math_cpowf;
 106 tree gfor_fndecl_math_cpow;
 107 tree gfor_fndecl_math_cpowl10;
 108 tree gfor_fndecl_math_cpowl16;
 109 tree gfor_fndecl_math_ishftc4;
 110 tree gfor_fndecl_math_ishftc8;
 111 tree gfor_fndecl_math_ishftc16;
 112 tree gfor_fndecl_math_exponent4;
 113 tree gfor_fndecl_math_exponent8;
 114 tree gfor_fndecl_math_exponent10;
 115 tree gfor_fndecl_math_exponent16;
 116
 117
 118 /* String functions.  */
 119
 120 tree gfor_fndecl_copy_string;
 121 tree gfor_fndecl_compare_string;
 122 tree gfor_fndecl_concat_string;
 123 tree gfor_fndecl_string_len_trim;
 124 tree gfor_fndecl_string_index;
 125 tree gfor_fndecl_string_scan;
 126 tree gfor_fndecl_string_verify;
 127 tree gfor_fndecl_string_trim;
 128 tree gfor_fndecl_string_repeat;
 129 tree gfor_fndecl_adjustl;
 130 tree gfor_fndecl_adjustr;
 131
 132
 133 /* Other misc. runtime library functions.  */
 134
 135 tree gfor_fndecl_size0;
 136 tree gfor_fndecl_size1;
 137 tree gfor_fndecl_iargc;
 138
 139 /* Intrinsic functions implemented in FORTRAN.  */
 140 tree gfor_fndecl_si_kind;
 141 tree gfor_fndecl_sr_kind;
 142
 143
 144 static void
 145 gfc_add_decl_to_parent_function (tree decl)
 146 {
 147   gcc_assert (decl);
 148   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 149   DECL_NONLOCAL (decl) = 1;
 150   TREE_CHAIN (decl) = saved_parent_function_decls;
 151   saved_parent_function_decls = decl;
 152 }
 153
 154 void
 155 gfc_add_decl_to_function (tree decl)
 156 {
 157   gcc_assert (decl);
 158   TREE_USED (decl) = 1;
 159   DECL_CONTEXT (decl) = current_function_decl;
 160   TREE_CHAIN (decl) = saved_function_decls;
 161   saved_function_decls = decl;
 162 }
 163
 164
 165 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 166    The context of the label is always the current_function_decl.  All
 167    labels are marked artificial.  */
 168
 169 tree
 170 gfc_build_label_decl (tree label_id)
 171 {
 172   /* 2^32 temporaries should be enough.  */
 173   static unsigned int tmp_num = 1;
 174   tree label_decl;
 175   char *label_name;
 176
 177   if (label_id == NULL_TREE)
 178     {
 179       /* Build an internal label name.  */
 180       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 181       label_id = get_identifier (label_name);
 182     }
 183   else
 184     label_name = NULL;
 185
 186   /* Build the LABEL_DECL node. Labels have no type.  */
 187   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 188   DECL_CONTEXT (label_decl) = current_function_decl;
 189   DECL_MODE (label_decl) = VOIDmode;
 190
 191   /* We always define the label as used, even if the original source
 192      file never references the label.  We don't want all kinds of
 193      spurious warnings for old-style Fortran code with too many
 194      labels.  */
 195   TREE_USED (label_decl) = 1;
 196
 197   DECL_ARTIFICIAL (label_decl) = 1;
 198   return label_decl;
 199 }
 200
 201
 202 /* Returns the return label for the current function.  */
 203
 204 tree
 205 gfc_get_return_label (void)
 206 {
 207   char name[GFC_MAX_SYMBOL_LEN + 10];
 208
 209   if (current_function_return_label)
 210     return current_function_return_label;
 211
 212   sprintf (name, "__return_%s",
 213            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 214
 215   current_function_return_label =
 216     gfc_build_label_decl (get_identifier (name));
 217
 218   DECL_ARTIFICIAL (current_function_return_label) = 1;
 219
 220   return current_function_return_label;
 221 }
 222
 223
 224 /* Set the backend source location of a decl.  */
 225
 226 void
 227 gfc_set_decl_location (tree decl, locus * loc)
 228 {
 229 #ifdef USE_MAPPED_LOCATION
 230   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 231 #else
 232   DECL_SOURCE_LINE (decl) = loc->lb->linenum;
 233   DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
 234 #endif
 235 }
 236
 237
 238 /* Return the backend label declaration for a given label structure,
 239    or create it if it doesn't exist yet.  */
 240
 241 tree
 242 gfc_get_label_decl (gfc_st_label * lp)
 243 {
 244   if (lp->backend_decl)
 245     return lp->backend_decl;
 246   else
 247     {
 248       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 249       tree label_decl;
 250
 251       /* Validate the label declaration from the front end.  */
 252       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 253
 254       /* Build a mangled name for the label.  */
 255       sprintf (label_name, "__label_%.6d", lp->value);
 256
 257       /* Build the LABEL_DECL node.  */
 258       label_decl = gfc_build_label_decl (get_identifier (label_name));
 259
 260       /* Tell the debugger where the label came from.  */
 261       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 262         gfc_set_decl_location (label_decl, &lp->where);
 263       else
 264         DECL_ARTIFICIAL (label_decl) = 1;
 265
 266       /* Store the label in the label list and return the LABEL_DECL.  */
 267       lp->backend_decl = label_decl;
 268       return label_decl;
 269     }
 270 }
 271
 272
 273 /* Convert a gfc_symbol to an identifier of the same name.  */
 274
 275 static tree
 276 gfc_sym_identifier (gfc_symbol * sym)
 277 {
 278   return (get_identifier (sym->name));
 279 }
 280
 281
 282 /* Construct mangled name from symbol name.  */
 283
 284 static tree
 285 gfc_sym_mangled_identifier (gfc_symbol * sym)
 286 {
 287   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 288
 289   if (sym->module == NULL)
 290     return gfc_sym_identifier (sym);
 291   else
 292     {
 293       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 294       return get_identifier (name);
 295     }
 296 }
 297
 298
 299 /* Construct mangled function name from symbol name.  */
 300
 301 static tree
 302 gfc_sym_mangled_function_id (gfc_symbol * sym)
 303 {
 304   int has_underscore;
 305   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 306
 307   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 308       || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
 309     {
 310       if (strcmp (sym->name, "MAIN__") == 0
 311           || sym->attr.proc == PROC_INTRINSIC)
 312         return get_identifier (sym->name);
 313
 314       if (gfc_option.flag_underscoring)
 315         {
 316           has_underscore = strchr (sym->name, '_') != 0;
 317           if (gfc_option.flag_second_underscore && has_underscore)
 318             snprintf (name, sizeof name, "%s__", sym->name);
 319           else
 320             snprintf (name, sizeof name, "%s_", sym->name);
 321           return get_identifier (name);
 322         }
 323       else
 324         return get_identifier (sym->name);
 325     }
 326   else
 327     {
 328       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 329       return get_identifier (name);
 330     }
 331 }
 332
 333
 334 /* Returns true if a variable of specified size should go on the stack.  */
 335
 336 int
 337 gfc_can_put_var_on_stack (tree size)
 338 {
 339   unsigned HOST_WIDE_INT low;
 340
 341   if (!INTEGER_CST_P (size))
 342     return 0;
 343
 344   if (gfc_option.flag_max_stack_var_size < 0)
 345     return 1;
 346
 347   if (TREE_INT_CST_HIGH (size) != 0)
 348     return 0;
 349
 350   low = TREE_INT_CST_LOW (size);
 351   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 352     return 0;
 353
 354 /* TODO: Set a per-function stack size limit.  */
 355
 356   return 1;
 357 }
 358
 359
 360 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 361    an expression involving its corresponding pointer.  There are
 362    2 cases; one for variable size arrays, and one for everything else,
 363    because variable-sized arrays require one fewer level of
 364    indirection.  */
 365
 366 static void
 367 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 368 {
 369   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 370   tree value;
 371
 372   /* Parameters need to be dereferenced.  */
 373   if (sym->cp_pointer->attr.dummy)
 374     ptr_decl = build_fold_indirect_ref (ptr_decl);
 375
 376   /* Check to see if we're dealing with a variable-sized array.  */
 377   if (sym->attr.dimension
 378       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 379     {
 380       /* These decls will be dereferenced later, so we don't dereference
 381          them here.  */
 382       value = convert (TREE_TYPE (decl), ptr_decl);
 383     }
 384   else
 385     {
 386       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 387                           ptr_decl);
 388       value = build_fold_indirect_ref (ptr_decl);
 389     }
 390
 391   SET_DECL_VALUE_EXPR (decl, value);
 392   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 393   GFC_DECL_CRAY_POINTEE (decl) = 1;
 394   /* This is a fake variable just for debugging purposes.  */
 395   TREE_ASM_WRITTEN (decl) = 1;
 396 }
 397
 398
 399 /* Finish processing of a declaration and install its initial value.  */
 400
 401 static void
 402 gfc_finish_decl (tree decl, tree init)
 403 {
 404   if (TREE_CODE (decl) == PARM_DECL)
 405     gcc_assert (init == NULL_TREE);
 406   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
 407      -- it overlaps DECL_ARG_TYPE.  */
 408   else if (init == NULL_TREE)
 409     gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
 410   else
 411     gcc_assert (DECL_INITIAL (decl) == error_mark_node);
 412
 413   if (init != NULL_TREE)
 414     {
 415       if (TREE_CODE (decl) != TYPE_DECL)
 416         DECL_INITIAL (decl) = init;
 417       else
 418         {
 419           /* typedef foo = bar; store the type of bar as the type of foo.  */
 420           TREE_TYPE (decl) = TREE_TYPE (init);
 421           DECL_INITIAL (decl) = init = 0;
 422         }
 423     }
 424
 425   if (TREE_CODE (decl) == VAR_DECL)
 426     {
 427       if (DECL_SIZE (decl) == NULL_TREE
 428           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 429         layout_decl (decl, 0);
 430
 431       /* A static variable with an incomplete type is an error if it is
 432          initialized. Also if it is not file scope. Otherwise, let it
 433          through, but if it is not `extern' then it may cause an error
 434          message later.  */
 435       /* An automatic variable with an incomplete type is an error.  */
 436       if (DECL_SIZE (decl) == NULL_TREE
 437           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
 438                                     || DECL_CONTEXT (decl) != 0)
 439                                  : !DECL_EXTERNAL (decl)))
 440         {
 441           gfc_fatal_error ("storage size not known");
 442         }
 443
 444       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
 445           && (DECL_SIZE (decl) != 0)
 446           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
 447         {
 448           gfc_fatal_error ("storage size not constant");
 449         }
 450     }
 451
 452 }
 453
 454
 455 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 456
 457 static void
 458 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 459 {
 460   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 461      This is the equivalent of the TARGET variables.
 462      We also need to set this if the variable is passed by reference in a
 463      CALL statement.  */
 464
 465   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 466   if (sym->attr.cray_pointee)
 467     gfc_finish_cray_pointee (decl, sym);
 468
 469   if (sym->attr.target)
 470     TREE_ADDRESSABLE (decl) = 1;
 471   /* If it wasn't used we wouldn't be getting it.  */
 472   TREE_USED (decl) = 1;
 473
 474   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 475      because this would add them to the current scope rather than the
 476      function scope.  */
 477   if (current_function_decl != NULL_TREE)
 478     {
 479       if (sym->ns->proc_name->backend_decl == current_function_decl
 480           || sym->result == sym)
 481         gfc_add_decl_to_function (decl);
 482       else
 483         gfc_add_decl_to_parent_function (decl);
 484     }
 485
 486   if (sym->attr.cray_pointee)
 487     return;
 488
 489   /* If a variable is USE associated, it's always external.  */
 490   if (sym->attr.use_assoc)
 491     {
 492       DECL_EXTERNAL (decl) = 1;
 493       TREE_PUBLIC (decl) = 1;
 494     }
 495   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 496     {
 497       /* TODO: Don't set sym->module for result or dummy variables.  */
 498       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 499       /* This is the declaration of a module variable.  */
 500       TREE_PUBLIC (decl) = 1;
 501       TREE_STATIC (decl) = 1;
 502     }
 503
 504   if ((sym->attr.save || sym->attr.data || sym->value)
 505       && !sym->attr.use_assoc)
 506     TREE_STATIC (decl) = 1;
 507
 508   /* Keep variables larger than max-stack-var-size off stack.  */
 509   if (!sym->ns->proc_name->attr.recursive
 510       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 511       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
 512     TREE_STATIC (decl) = 1;
 513
 514   /* Handle threadprivate variables.  */
 515   if (sym->attr.threadprivate && targetm.have_tls
 516       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
 517     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
 518 }
 519
 520
 521 /* Allocate the lang-specific part of a decl.  */
 522
 523 void
 524 gfc_allocate_lang_decl (tree decl)
 525 {
 526   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 527     ggc_alloc_cleared (sizeof (struct lang_decl));
 528 }
 529
 530 /* Remember a symbol to generate initialization/cleanup code at function
 531    entry/exit.  */
 532
 533 static void
 534 gfc_defer_symbol_init (gfc_symbol * sym)
 535 {
 536   gfc_symbol *p;
 537   gfc_symbol *last;
 538   gfc_symbol *head;
 539
 540   /* Don't add a symbol twice.  */
 541   if (sym->tlink)
 542     return;
 543
 544   last = head = sym->ns->proc_name;
 545   p = last->tlink;
 546
 547   /* Make sure that setup code for dummy variables which are used in the
 548      setup of other variables is generated first.  */
 549   if (sym->attr.dummy)
 550     {
 551       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 552          This is a circular list, so don't go past the head.  */
 553       while (p != head
 554              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 555         {
 556           last = p;
 557           p = p->tlink;
 558         }
 559     }
 560   /* Insert in between last and p.  */
 561   last->tlink = sym;
 562   sym->tlink = p;
 563 }
 564
 565
 566 /* Create an array index type variable with function scope.  */
 567
 568 static tree
 569 create_index_var (const char * pfx, int nest)
 570 {
 571   tree decl;
 572
 573   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 574   if (nest)
 575     gfc_add_decl_to_parent_function (decl);
 576   else
 577     gfc_add_decl_to_function (decl);
 578   return decl;
 579 }
 580
 581
 582 /* Create variables to hold all the non-constant bits of info for a
 583    descriptorless array.  Remember these in the lang-specific part of the
 584    type.  */
 585
 586 static void
 587 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 588 {
 589   tree type;
 590   int dim;
 591   int nest;
 592
 593   type = TREE_TYPE (decl);
 594
 595   /* We just use the descriptor, if there is one.  */
 596   if (GFC_DESCRIPTOR_TYPE_P (type))
 597     return;
 598
 599   gcc_assert (GFC_ARRAY_TYPE_P (type));
 600   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 601          && !sym->attr.contained;
 602
 603   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 604     {
 605       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 606         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 607       /* Don't try to use the unknown bound for assumed shape arrays.  */
 608       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 609           && (sym->as->type != AS_ASSUMED_SIZE
 610               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 611         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 612
 613       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 614         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 615     }
 616   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 617     {
 618       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 619                                                         "offset");
 620       if (nest)
 621         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 622       else
 623         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 624     }
 625
 626   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
 627       && sym->as->type != AS_ASSUMED_SIZE)
 628     GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
 629
 630   if (POINTER_TYPE_P (type))
 631     {
 632       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
 633       gcc_assert (TYPE_LANG_SPECIFIC (type)
 634                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
 635       type = TREE_TYPE (type);
 636     }
 637
 638   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
 639     {
 640       tree size, range;
 641
 642       size = build2 (MINUS_EXPR, gfc_array_index_type,
 643                      GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
 644       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 645                                 size);
 646       TYPE_DOMAIN (type) = range;
 647       layout_type (type);
 648     }
 649 }
 650
 651
 652 /* For some dummy arguments we don't use the actual argument directly.
 653    Instead we create a local decl and use that.  This allows us to perform
 654    initialization, and construct full type information.  */
 655
 656 static tree
 657 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 658 {
 659   tree decl;
 660   tree type;
 661   gfc_array_spec *as;
 662   char *name;
 663   int packed;
 664   int n;
 665   bool known_size;
 666
 667   if (sym->attr.pointer || sym->attr.allocatable)
 668     return dummy;
 669
 670   /* Add to list of variables if not a fake result variable.  */
 671   if (sym->attr.result || sym->attr.dummy)
 672     gfc_defer_symbol_init (sym);
 673
 674   type = TREE_TYPE (dummy);
 675   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 676           && POINTER_TYPE_P (type));
 677
 678   /* Do we know the element size?  */
 679   known_size = sym->ts.type != BT_CHARACTER
 680           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 681
 682   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 683     {
 684       /* For descriptorless arrays with known element size the actual
 685          argument is sufficient.  */
 686       gcc_assert (GFC_ARRAY_TYPE_P (type));
 687       gfc_build_qualified_array (dummy, sym);
 688       return dummy;
 689     }
 690
 691   type = TREE_TYPE (type);
 692   if (GFC_DESCRIPTOR_TYPE_P (type))
 693     {
 694       /* Create a decriptorless array pointer.  */
 695       as = sym->as;
 696       packed = 0;
 697       if (!gfc_option.flag_repack_arrays)
 698         {
 699           if (as->type == AS_ASSUMED_SIZE)
 700             packed = 2;
 701         }
 702       else
 703         {
 704           if (as->type == AS_EXPLICIT)
 705             {
 706               packed = 2;
 707               for (n = 0; n < as->rank; n++)
 708                 {
 709                   if (!(as->upper[n]
 710                         && as->lower[n]
 711                         && as->upper[n]->expr_type == EXPR_CONSTANT
 712                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 713                     packed = 1;
 714                 }
 715             }
 716           else
 717             packed = 1;
 718         }
 719
 720       type = gfc_typenode_for_spec (&sym->ts);
 721       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 722     }
 723   else
 724     {
 725       /* We now have an expression for the element size, so create a fully
 726          qualified type.  Reset sym->backend decl or this will just return the
 727          old type.  */
 728       sym->backend_decl = NULL_TREE;
 729       type = gfc_sym_type (sym);
 730       packed = 2;
 731     }
 732
 733   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 734   decl = build_decl (VAR_DECL, get_identifier (name), type);
 735
 736   DECL_ARTIFICIAL (decl) = 1;
 737   TREE_PUBLIC (decl) = 0;
 738   TREE_STATIC (decl) = 0;
 739   DECL_EXTERNAL (decl) = 0;
 740
 741   /* We should never get deferred shape arrays here.  We used to because of
 742      frontend bugs.  */
 743   gcc_assert (sym->as->type != AS_DEFERRED);
 744
 745   switch (packed)
 746     {
 747     case 1:
 748       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 749       break;
 750
 751     case 2:
 752       GFC_DECL_PACKED_ARRAY (decl) = 1;
 753       break;
 754     }
 755
 756   gfc_build_qualified_array (decl, sym);
 757
 758   if (DECL_LANG_SPECIFIC (dummy))
 759     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 760   else
 761     gfc_allocate_lang_decl (decl);
 762
 763   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 764
 765   if (sym->ns->proc_name->backend_decl == current_function_decl
 766       || sym->attr.contained)
 767     gfc_add_decl_to_function (decl);
 768   else
 769     gfc_add_decl_to_parent_function (decl);
 770
 771   return decl;
 772 }
 773
 774
 775 /* Return a constant or a variable to use as a string length.  Does not
 776    add the decl to the current scope.  */
 777
 778 static tree
 779 gfc_create_string_length (gfc_symbol * sym)
 780 {
 781   tree length;
 782
 783   gcc_assert (sym->ts.cl);
 784   gfc_conv_const_charlen (sym->ts.cl);
 785
 786   if (sym->ts.cl->backend_decl == NULL_TREE)
 787     {
 788       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 789
 790       /* Also prefix the mangled name.  */
 791       strcpy (&name[1], sym->name);
 792       name[0] = '.';
 793       length = build_decl (VAR_DECL, get_identifier (name),
 794                            gfc_charlen_type_node);
 795       DECL_ARTIFICIAL (length) = 1;
 796       TREE_USED (length) = 1;
 797       if (sym->ns->proc_name->tlink != NULL)
 798         gfc_defer_symbol_init (sym);
 799       sym->ts.cl->backend_decl = length;
 800     }
 801
 802   return sym->ts.cl->backend_decl;
 803 }
 804
 805 /* If a variable is assigned a label, we add another two auxiliary
 806    variables.  */
 807
 808 static void
 809 gfc_add_assign_aux_vars (gfc_symbol * sym)
 810 {
 811   tree addr;
 812   tree length;
 813   tree decl;
 814
 815   gcc_assert (sym->backend_decl);
 816
 817   decl = sym->backend_decl;
 818   gfc_allocate_lang_decl (decl);
 819   GFC_DECL_ASSIGN (decl) = 1;
 820   length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 821                        gfc_charlen_type_node);
 822   addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 823                      pvoid_type_node);
 824   gfc_finish_var_decl (length, sym);
 825   gfc_finish_var_decl (addr, sym);
 826   /*  STRING_LENGTH is also used as flag. Less than -1 means that
 827       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 828       target label's address. Otherwise, value is the length of a format string
 829       and ASSIGN_ADDR is its address.  */
 830   if (TREE_STATIC (length))
 831     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
 832   else
 833     gfc_defer_symbol_init (sym);
 834
 835   GFC_DECL_STRING_LEN (decl) = length;
 836   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 837 }
 838
 839 /* Return the decl for a gfc_symbol, create it if it doesn't already
 840    exist.  */
 841
 842 tree
 843 gfc_get_symbol_decl (gfc_symbol * sym)
 844 {
 845   tree decl;
 846   tree length = NULL_TREE;
 847   int byref;
 848
 849   gcc_assert (sym->attr.referenced);
 850
 851   if (sym->ns && sym->ns->proc_name->attr.function)
 852     byref = gfc_return_by_reference (sym->ns->proc_name);
 853   else
 854     byref = 0;
 855
 856   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
 857     {
 858       /* Return via extra parameter.  */
 859       if (sym->attr.result && byref
 860           && !sym->backend_decl)
 861         {
 862           sym->backend_decl =
 863             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
 864           /* For entry master function skip over the __entry
 865              argument.  */
 866           if (sym->ns->proc_name->attr.entry_master)
 867             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
 868         }
 869
 870       /* Dummy variables should already have been created.  */
 871       gcc_assert (sym->backend_decl);
 872
 873       /* Create a character length variable.  */
 874       if (sym->ts.type == BT_CHARACTER)
 875         {
 876           if (sym->ts.cl->backend_decl == NULL_TREE)
 877             length = gfc_create_string_length (sym);
 878           else
 879             length = sym->ts.cl->backend_decl;
 880           if (TREE_CODE (length) == VAR_DECL
 881               && DECL_CONTEXT (length) == NULL_TREE)
 882             {
 883               gfc_add_decl_to_function (length);
 884               gfc_defer_symbol_init (sym);
 885             }
 886         }
 887
 888       /* Use a copy of the descriptor for dummy arrays.  */
 889       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
 890         {
 891           sym->backend_decl =
 892             gfc_build_dummy_array_decl (sym, sym->backend_decl);
 893         }
 894
 895       TREE_USED (sym->backend_decl) = 1;
 896       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
 897         {
 898           gfc_add_assign_aux_vars (sym);
 899         }
 900       return sym->backend_decl;
 901     }
 902
 903   if (sym->backend_decl)
 904     return sym->backend_decl;
 905
 906   /* Catch function declarations.  Only used for actual parameters.  */
 907   if (sym->attr.flavor == FL_PROCEDURE)
 908     {
 909       decl = gfc_get_extern_function_decl (sym);
 910       return decl;
 911     }
 912
 913   if (sym->attr.intrinsic)
 914     internal_error ("intrinsic variable which isn't a procedure");
 915
 916   /* Create string length decl first so that they can be used in the
 917      type declaration.  */
 918   if (sym->ts.type == BT_CHARACTER)
 919     length = gfc_create_string_length (sym);
 920
 921   /* Create the decl for the variable.  */
 922   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 923
 924   gfc_set_decl_location (decl, &sym->declared_at);
 925
 926   /* Symbols from modules should have their assembler names mangled.
 927      This is done here rather than in gfc_finish_var_decl because it
 928      is different for string length variables.  */
 929   if (sym->module)
 930     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
 931
 932   if (sym->attr.dimension)
 933     {
 934       /* Create variables to hold the non-constant bits of array info.  */
 935       gfc_build_qualified_array (decl, sym);
 936
 937       /* Remember this variable for allocation/cleanup.  */
 938       gfc_defer_symbol_init (sym);
 939
 940       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
 941         GFC_DECL_PACKED_ARRAY (decl) = 1;
 942     }
 943
 944   gfc_finish_var_decl (decl, sym);
 945
 946   if (sym->ts.type == BT_CHARACTER)
 947     {
 948       /* Character variables need special handling.  */
 949       gfc_allocate_lang_decl (decl);
 950
 951       if (TREE_CODE (length) != INTEGER_CST)
 952         {
 953           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 954
 955           if (sym->module)
 956             {
 957               /* Also prefix the mangled name for symbols from modules.  */
 958               strcpy (&name[1], sym->name);
 959               name[0] = '.';
 960               strcpy (&name[1],
 961                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
 962               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
 963             }
 964           gfc_finish_var_decl (length, sym);
 965           gcc_assert (!sym->value);
 966         }
 967     }
 968   sym->backend_decl = decl;
 969
 970   if (sym->attr.assign)
 971     {
 972       gfc_add_assign_aux_vars (sym);
 973     }
 974
 975   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
 976     {
 977       /* Add static initializer.  */
 978       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
 979           TREE_TYPE (decl), sym->attr.dimension,
 980           sym->attr.pointer || sym->attr.allocatable);
 981     }
 982
 983   return decl;
 984 }
 985
 986
 987 /* Substitute a temporary variable in place of the real one.  */
 988
 989 void
 990 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
 991 {
 992   save->attr = sym->attr;
 993   save->decl = sym->backend_decl;
 994
 995   gfc_clear_attr (&sym->attr);
 996   sym->attr.referenced = 1;
 997   sym->attr.flavor = FL_VARIABLE;
 998
 999   sym->backend_decl = decl;
1000 }
1001
1002
1003 /* Restore the original variable.  */
1004
1005 void
1006 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1007 {
1008   sym->attr = save->attr;
1009   sym->backend_decl = save->decl;
1010 }
1011
1012
1013 /* Get a basic decl for an external function.  */
1014
1015 tree
1016 gfc_get_extern_function_decl (gfc_symbol * sym)
1017 {
1018   tree type;
1019   tree fndecl;
1020   gfc_expr e;
1021   gfc_intrinsic_sym *isym;
1022   gfc_expr argexpr;
1023   char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'.  */
1024   tree name;
1025   tree mangled_name;
1026
1027   if (sym->backend_decl)
1028     return sym->backend_decl;
1029
1030   /* We should never be creating external decls for alternate entry points.
1031      The procedure may be an alternate entry point, but we don't want/need
1032      to know that.  */
1033   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1034
1035   if (sym->attr.intrinsic)
1036     {
1037       /* Call the resolution function to get the actual name.  This is
1038          a nasty hack which relies on the resolution functions only looking
1039          at the first argument.  We pass NULL for the second argument
1040          otherwise things like AINT get confused.  */
1041       isym = gfc_find_function (sym->name);
1042       gcc_assert (isym->resolve.f0 != NULL);
1043
1044       memset (&e, 0, sizeof (e));
1045       e.expr_type = EXPR_FUNCTION;
1046
1047       memset (&argexpr, 0, sizeof (argexpr));
1048       gcc_assert (isym->formal);
1049       argexpr.ts = isym->formal->ts;
1050
1051       if (isym->formal->next == NULL)
1052         isym->resolve.f1 (&e, &argexpr);
1053       else
1054         {
1055           /* All specific intrinsics take one or two arguments.  */
1056           gcc_assert (isym->formal->next->next == NULL);
1057           isym->resolve.f2 (&e, &argexpr, NULL);
1058         }
1059
1060       if (gfc_option.flag_f2c
1061           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1062               || e.ts.type == BT_COMPLEX))
1063         {
1064           /* Specific which needs a different implementation if f2c
1065              calling conventions are used.  */
1066           sprintf (s, "f2c_specific%s", e.value.function.name);
1067         }
1068       else
1069         sprintf (s, "specific%s", e.value.function.name);
1070
1071       name = get_identifier (s);
1072       mangled_name = name;
1073     }
1074   else
1075     {
1076       name = gfc_sym_identifier (sym);
1077       mangled_name = gfc_sym_mangled_function_id (sym);
1078     }
1079
1080   type = gfc_get_function_type (sym);
1081   fndecl = build_decl (FUNCTION_DECL, name, type);
1082
1083   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1084   /* If the return type is a pointer, avoid alias issues by setting
1085      DECL_IS_MALLOC to nonzero. This means that the function should be
1086      treated as if it were a malloc, meaning it returns a pointer that
1087      is not an alias.  */
1088   if (POINTER_TYPE_P (type))
1089     DECL_IS_MALLOC (fndecl) = 1;
1090
1091   /* Set the context of this decl.  */
1092   if (0 && sym->ns && sym->ns->proc_name)
1093     {
1094       /* TODO: Add external decls to the appropriate scope.  */
1095       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1096     }
1097   else
1098     {
1099       /* Global declaration, e.g. intrinsic subroutine.  */
1100       DECL_CONTEXT (fndecl) = NULL_TREE;
1101     }
1102
1103   DECL_EXTERNAL (fndecl) = 1;
1104
1105   /* This specifies if a function is globally addressable, i.e. it is
1106      the opposite of declaring static in C.  */
1107   TREE_PUBLIC (fndecl) = 1;
1108
1109   /* Set attributes for PURE functions. A call to PURE function in the
1110      Fortran 95 sense is both pure and without side effects in the C
1111      sense.  */
1112   if (sym->attr.pure || sym->attr.elemental)
1113     {
1114       if (sym->attr.function && !gfc_return_by_reference (sym))
1115         DECL_IS_PURE (fndecl) = 1;
1116       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1117          parameters and don't use alternate returns (is this
1118          allowed?). In that case, calls to them are meaningless, and
1119          can be optimized away. See also in build_function_decl().  */
1120       TREE_SIDE_EFFECTS (fndecl) = 0;
1121     }
1122
1123   /* Mark non-returning functions.  */
1124   if (sym->attr.noreturn)
1125       TREE_THIS_VOLATILE(fndecl) = 1;
1126
1127   sym->backend_decl = fndecl;
1128
1129   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1130     pushdecl_top_level (fndecl);
1131
1132   return fndecl;
1133 }
1134
1135
1136 /* Create a declaration for a procedure.  For external functions (in the C
1137    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1138    a master function with alternate entry points.  */
1139
1140 static void
1141 build_function_decl (gfc_symbol * sym)
1142 {
1143   tree fndecl, type;
1144   symbol_attribute attr;
1145   tree result_decl;
1146   gfc_formal_arglist *f;
1147
1148   gcc_assert (!sym->backend_decl);
1149   gcc_assert (!sym->attr.external);
1150
1151   /* Set the line and filename.  sym->declared_at seems to point to the
1152      last statement for subroutines, but it'll do for now.  */
1153   gfc_set_backend_locus (&sym->declared_at);
1154
1155   /* Allow only one nesting level.  Allow public declarations.  */
1156   gcc_assert (current_function_decl == NULL_TREE
1157           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1158
1159   type = gfc_get_function_type (sym);
1160   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1161
1162   /* Perform name mangling if this is a top level or module procedure.  */
1163   if (current_function_decl == NULL_TREE)
1164     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1165
1166   /* Figure out the return type of the declared function, and build a
1167      RESULT_DECL for it.  If this is a subroutine with alternate
1168      returns, build a RESULT_DECL for it.  */
1169   attr = sym->attr;
1170
1171   result_decl = NULL_TREE;
1172   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1173   if (attr.function)
1174     {
1175       if (gfc_return_by_reference (sym))
1176         type = void_type_node;
1177       else
1178         {
1179           if (sym->result != sym)
1180             result_decl = gfc_sym_identifier (sym->result);
1181
1182           type = TREE_TYPE (TREE_TYPE (fndecl));
1183         }
1184     }
1185   else
1186     {
1187       /* Look for alternate return placeholders.  */
1188       int has_alternate_returns = 0;
1189       for (f = sym->formal; f; f = f->next)
1190         {
1191           if (f->sym == NULL)
1192             {
1193               has_alternate_returns = 1;
1194               break;
1195             }
1196         }
1197
1198       if (has_alternate_returns)
1199         type = integer_type_node;
1200       else
1201         type = void_type_node;
1202     }
1203
1204   result_decl = build_decl (RESULT_DECL, result_decl, type);
1205   DECL_ARTIFICIAL (result_decl) = 1;
1206   DECL_IGNORED_P (result_decl) = 1;
1207   DECL_CONTEXT (result_decl) = fndecl;
1208   DECL_RESULT (fndecl) = result_decl;
1209
1210   /* Don't call layout_decl for a RESULT_DECL.
1211      layout_decl (result_decl, 0);  */
1212
1213   /* If the return type is a pointer, avoid alias issues by setting
1214      DECL_IS_MALLOC to nonzero. This means that the function should be
1215      treated as if it were a malloc, meaning it returns a pointer that
1216      is not an alias.  */
1217   if (POINTER_TYPE_P (type))
1218     DECL_IS_MALLOC (fndecl) = 1;
1219
1220   /* Set up all attributes for the function.  */
1221   DECL_CONTEXT (fndecl) = current_function_decl;
1222   DECL_EXTERNAL (fndecl) = 0;
1223
1224   /* This specifies if a function is globally visible, i.e. it is
1225      the opposite of declaring static in C.  */
1226   if (DECL_CONTEXT (fndecl) == NULL_TREE
1227       && !sym->attr.entry_master)
1228     TREE_PUBLIC (fndecl) = 1;
1229
1230   /* TREE_STATIC means the function body is defined here.  */
1231   TREE_STATIC (fndecl) = 1;
1232
1233   /* Set attributes for PURE functions. A call to a PURE function in the
1234      Fortran 95 sense is both pure and without side effects in the C
1235      sense.  */
1236   if (attr.pure || attr.elemental)
1237     {
1238       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1239          including a alternate return. In that case it can also be
1240          marked as PURE. See also in gfc_get_extern_function_decl().  */
1241       if (attr.function && !gfc_return_by_reference (sym))
1242         DECL_IS_PURE (fndecl) = 1;
1243       TREE_SIDE_EFFECTS (fndecl) = 0;
1244     }
1245
1246   /* Layout the function declaration and put it in the binding level
1247      of the current function.  */
1248   pushdecl (fndecl);
1249
1250   sym->backend_decl = fndecl;
1251 }
1252
1253
1254 /* Create the DECL_ARGUMENTS for a procedure.  */
1255
1256 static void
1257 create_function_arglist (gfc_symbol * sym)
1258 {
1259   tree fndecl;
1260   gfc_formal_arglist *f;
1261   tree typelist, hidden_typelist;
1262   tree arglist, hidden_arglist;
1263   tree type;
1264   tree parm;
1265
1266   fndecl = sym->backend_decl;
1267
1268   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1269      the new FUNCTION_DECL node.  */
1270   arglist = NULL_TREE;
1271   hidden_arglist = NULL_TREE;
1272   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1273
1274   if (sym->attr.entry_master)
1275     {
1276       type = TREE_VALUE (typelist);
1277       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1278
1279       DECL_CONTEXT (parm) = fndecl;
1280       DECL_ARG_TYPE (parm) = type;
1281       TREE_READONLY (parm) = 1;
1282       gfc_finish_decl (parm, NULL_TREE);
1283
1284       arglist = chainon (arglist, parm);
1285       typelist = TREE_CHAIN (typelist);
1286     }
1287
1288   if (gfc_return_by_reference (sym))
1289     {
1290       tree type = TREE_VALUE (typelist), length = NULL;
1291
1292       if (sym->ts.type == BT_CHARACTER)
1293         {
1294           /* Length of character result.  */
1295           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1296           gcc_assert (len_type == gfc_charlen_type_node);
1297
1298           length = build_decl (PARM_DECL,
1299                                get_identifier (".__result"),
1300                                len_type);
1301           if (!sym->ts.cl->length)
1302             {
1303               sym->ts.cl->backend_decl = length;
1304               TREE_USED (length) = 1;
1305             }
1306           gcc_assert (TREE_CODE (length) == PARM_DECL);
1307           DECL_CONTEXT (length) = fndecl;
1308           DECL_ARG_TYPE (length) = len_type;
1309           TREE_READONLY (length) = 1;
1310           DECL_ARTIFICIAL (length) = 1;
1311           gfc_finish_decl (length, NULL_TREE);
1312           if (sym->ts.cl->backend_decl == NULL
1313               || sym->ts.cl->backend_decl == length)
1314             {
1315               gfc_symbol *arg;
1316               tree backend_decl;
1317
1318               if (sym->ts.cl->backend_decl == NULL)
1319                 {
1320                   tree len = build_decl (VAR_DECL,
1321                                          get_identifier ("..__result"),
1322                                          gfc_charlen_type_node);
1323                   DECL_ARTIFICIAL (len) = 1;
1324                   TREE_USED (len) = 1;
1325                   sym->ts.cl->backend_decl = len;
1326                 }
1327
1328               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1329               arg = sym->result ? sym->result : sym;
1330               backend_decl = arg->backend_decl;
1331               /* Temporary clear it, so that gfc_sym_type creates complete
1332                  type.  */
1333               arg->backend_decl = NULL;
1334               type = gfc_sym_type (arg);
1335               arg->backend_decl = backend_decl;
1336               type = build_reference_type (type);
1337             }
1338         }
1339
1340       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1341
1342       DECL_CONTEXT (parm) = fndecl;
1343       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1344       TREE_READONLY (parm) = 1;
1345       DECL_ARTIFICIAL (parm) = 1;
1346       gfc_finish_decl (parm, NULL_TREE);
1347
1348       arglist = chainon (arglist, parm);
1349       typelist = TREE_CHAIN (typelist);
1350
1351       if (sym->ts.type == BT_CHARACTER)
1352         {
1353           gfc_allocate_lang_decl (parm);
1354           arglist = chainon (arglist, length);
1355           typelist = TREE_CHAIN (typelist);
1356         }
1357     }
1358
1359   hidden_typelist = typelist;
1360   for (f = sym->formal; f; f = f->next)
1361     if (f->sym != NULL) /* Ignore alternate returns.  */
1362       hidden_typelist = TREE_CHAIN (hidden_typelist);
1363
1364   for (f = sym->formal; f; f = f->next)
1365     {
1366       char name[GFC_MAX_SYMBOL_LEN + 2];
1367
1368       /* Ignore alternate returns.  */
1369       if (f->sym == NULL)
1370         continue;
1371
1372       type = TREE_VALUE (typelist);
1373
1374       if (f->sym->ts.type == BT_CHARACTER)
1375         {
1376           tree len_type = TREE_VALUE (hidden_typelist);
1377           tree length = NULL_TREE;
1378           gcc_assert (len_type == gfc_charlen_type_node);
1379
1380           strcpy (&name[1], f->sym->name);
1381           name[0] = '_';
1382           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1383
1384           hidden_arglist = chainon (hidden_arglist, length);
1385           DECL_CONTEXT (length) = fndecl;
1386           DECL_ARTIFICIAL (length) = 1;
1387           DECL_ARG_TYPE (length) = len_type;
1388           TREE_READONLY (length) = 1;
1389           gfc_finish_decl (length, NULL_TREE);
1390
1391           /* TODO: Check string lengths when -fbounds-check.  */
1392
1393           /* Use the passed value for assumed length variables.  */
1394           if (!f->sym->ts.cl->length)
1395             {
1396               TREE_USED (length) = 1;
1397               if (!f->sym->ts.cl->backend_decl)
1398                 f->sym->ts.cl->backend_decl = length;
1399               else
1400                 {
1401                   /* there is already another variable using this
1402                      gfc_charlen node, build a new one for this variable
1403                      and chain it into the list of gfc_charlens.
1404                      This happens for e.g. in the case
1405                      CHARACTER(*)::c1,c2
1406                      since CHARACTER declarations on the same line share
1407                      the same gfc_charlen node.  */
1408                   gfc_charlen *cl;
1409
1410                   cl = gfc_get_charlen ();
1411                   cl->backend_decl = length;
1412                   cl->next = f->sym->ts.cl->next;
1413                   f->sym->ts.cl->next = cl;
1414                   f->sym->ts.cl = cl;
1415                 }
1416             }
1417
1418           hidden_typelist = TREE_CHAIN (hidden_typelist);
1419
1420           if (f->sym->ts.cl->backend_decl == NULL
1421               || f->sym->ts.cl->backend_decl == length)
1422             {
1423               if (f->sym->ts.cl->backend_decl == NULL)
1424                 gfc_create_string_length (f->sym);
1425
1426               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1427               if (f->sym->attr.flavor == FL_PROCEDURE)
1428                 type = build_pointer_type (gfc_get_function_type (f->sym));
1429               else
1430                 type = gfc_sym_type (f->sym);
1431             }
1432         }
1433
1434       /* For non-constant length array arguments, make sure they use
1435          a different type node from TYPE_ARG_TYPES type.  */
1436       if (f->sym->attr.dimension
1437           && type == TREE_VALUE (typelist)
1438           && TREE_CODE (type) == POINTER_TYPE
1439           && GFC_ARRAY_TYPE_P (type)
1440           && f->sym->as->type != AS_ASSUMED_SIZE
1441           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1442         {
1443           if (f->sym->attr.flavor == FL_PROCEDURE)
1444             type = build_pointer_type (gfc_get_function_type (f->sym));
1445           else
1446             type = gfc_sym_type (f->sym);
1447         }
1448
1449       /* Build a the argument declaration.  */
1450       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1451
1452       /* Fill in arg stuff.  */
1453       DECL_CONTEXT (parm) = fndecl;
1454       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1455       /* All implementation args are read-only.  */
1456       TREE_READONLY (parm) = 1;
1457
1458       gfc_finish_decl (parm, NULL_TREE);
1459
1460       f->sym->backend_decl = parm;
1461
1462       arglist = chainon (arglist, parm);
1463       typelist = TREE_CHAIN (typelist);
1464     }
1465
1466   /* Add the hidden string length parameters.  */
1467   arglist = chainon (arglist, hidden_arglist);
1468
1469   gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
1470   DECL_ARGUMENTS (fndecl) = arglist;
1471 }
1472
1473 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1474
1475 static void
1476 gfc_gimplify_function (tree fndecl)
1477 {
1478   struct cgraph_node *cgn;
1479
1480   gimplify_function_tree (fndecl);
1481   dump_function (TDI_generic, fndecl);
1482
1483   /* Generate errors for structured block violations.  */
1484   /* ??? Could be done as part of resolve_labels.  */
1485   if (flag_openmp)
1486     diagnose_omp_structured_block_errors (fndecl);
1487
1488   /* Convert all nested functions to GIMPLE now.  We do things in this order
1489      so that items like VLA sizes are expanded properly in the context of the
1490      correct function.  */
1491   cgn = cgraph_node (fndecl);
1492   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1493     gfc_gimplify_function (cgn->decl);
1494 }
1495
1496
1497 /* Do the setup necessary before generating the body of a function.  */
1498
1499 static void
1500 trans_function_start (gfc_symbol * sym)
1501 {
1502   tree fndecl;
1503
1504   fndecl = sym->backend_decl;
1505
1506   /* Let GCC know the current scope is this function.  */
1507   current_function_decl = fndecl;
1508
1509   /* Let the world know what we're about to do.  */
1510   announce_function (fndecl);
1511
1512   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1513     {
1514       /* Create RTL for function declaration.  */
1515       rest_of_decl_compilation (fndecl, 1, 0);
1516     }
1517
1518   /* Create RTL for function definition.  */
1519   make_decl_rtl (fndecl);
1520
1521   init_function_start (fndecl);
1522
1523   /* Even though we're inside a function body, we still don't want to
1524      call expand_expr to calculate the size of a variable-sized array.
1525      We haven't necessarily assigned RTL to all variables yet, so it's
1526      not safe to try to expand expressions involving them.  */
1527   cfun->x_dont_save_pending_sizes_p = 1;
1528
1529   /* function.c requires a push at the start of the function.  */
1530   pushlevel (0);
1531 }
1532
1533 /* Create thunks for alternate entry points.  */
1534
1535 static void
1536 build_entry_thunks (gfc_namespace * ns)
1537 {
1538   gfc_formal_arglist *formal;
1539   gfc_formal_arglist *thunk_formal;
1540   gfc_entry_list *el;
1541   gfc_symbol *thunk_sym;
1542   stmtblock_t body;
1543   tree thunk_fndecl;
1544   tree args;
1545   tree string_args;
1546   tree tmp;
1547   locus old_loc;
1548
1549   /* This should always be a toplevel function.  */
1550   gcc_assert (current_function_decl == NULL_TREE);
1551
1552   gfc_get_backend_locus (&old_loc);
1553   for (el = ns->entries; el; el = el->next)
1554     {
1555       thunk_sym = el->sym;
1556
1557       build_function_decl (thunk_sym);
1558       create_function_arglist (thunk_sym);
1559
1560       trans_function_start (thunk_sym);
1561
1562       thunk_fndecl = thunk_sym->backend_decl;
1563
1564       gfc_start_block (&body);
1565
1566       /* Pass extra parameter identifying this entry point.  */
1567       tmp = build_int_cst (gfc_array_index_type, el->id);
1568       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1569       string_args = NULL_TREE;
1570
1571       if (thunk_sym->attr.function)
1572         {
1573           if (gfc_return_by_reference (ns->proc_name))
1574             {
1575               tree ref = DECL_ARGUMENTS (current_function_decl);
1576               args = tree_cons (NULL_TREE, ref, args);
1577               if (ns->proc_name->ts.type == BT_CHARACTER)
1578                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1579                                   args);
1580             }
1581         }
1582
1583       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1584         {
1585           /* Ignore alternate returns.  */
1586           if (formal->sym == NULL)
1587             continue;
1588
1589           /* We don't have a clever way of identifying arguments, so resort to
1590              a brute-force search.  */
1591           for (thunk_formal = thunk_sym->formal;
1592                thunk_formal;
1593                thunk_formal = thunk_formal->next)
1594             {
1595               if (thunk_formal->sym == formal->sym)
1596                 break;
1597             }
1598
1599           if (thunk_formal)
1600             {
1601               /* Pass the argument.  */
1602               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1603                                 args);
1604               if (formal->sym->ts.type == BT_CHARACTER)
1605                 {
1606                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1607                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1608                 }
1609             }
1610           else
1611             {
1612               /* Pass NULL for a missing argument.  */
1613               args = tree_cons (NULL_TREE, null_pointer_node, args);
1614               if (formal->sym->ts.type == BT_CHARACTER)
1615                 {
1616                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1617                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1618                 }
1619             }
1620         }
1621
1622       /* Call the master function.  */
1623       args = nreverse (args);
1624       args = chainon (args, nreverse (string_args));
1625       tmp = ns->proc_name->backend_decl;
1626       tmp = build_function_call_expr (tmp, args);
1627       if (ns->proc_name->attr.mixed_entry_master)
1628         {
1629           tree union_decl, field;
1630           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1631
1632           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1633                                    TREE_TYPE (master_type));
1634           DECL_ARTIFICIAL (union_decl) = 1;
1635           DECL_EXTERNAL (union_decl) = 0;
1636           TREE_PUBLIC (union_decl) = 0;
1637           TREE_USED (union_decl) = 1;
1638           layout_decl (union_decl, 0);
1639           pushdecl (union_decl);
1640
1641           DECL_CONTEXT (union_decl) = current_function_decl;
1642           tmp = build2 (MODIFY_EXPR,
1643                         TREE_TYPE (union_decl),
1644                         union_decl, tmp);
1645           gfc_add_expr_to_block (&body, tmp);
1646
1647           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1648                field; field = TREE_CHAIN (field))
1649             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1650                 thunk_sym->result->name) == 0)
1651               break;
1652           gcc_assert (field != NULL_TREE);
1653           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1654                         NULL_TREE);
1655           tmp = build2 (MODIFY_EXPR,
1656                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1657                         DECL_RESULT (current_function_decl), tmp);
1658           tmp = build1_v (RETURN_EXPR, tmp);
1659         }
1660       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1661                != void_type_node)
1662         {
1663           tmp = build2 (MODIFY_EXPR,
1664                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1665                         DECL_RESULT (current_function_decl), tmp);
1666           tmp = build1_v (RETURN_EXPR, tmp);
1667         }
1668       gfc_add_expr_to_block (&body, tmp);
1669
1670       /* Finish off this function and send it for code generation.  */
1671       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1672       poplevel (1, 0, 1);
1673       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1674
1675       /* Output the GENERIC tree.  */
1676       dump_function (TDI_original, thunk_fndecl);
1677
1678       /* Store the end of the function, so that we get good line number
1679          info for the epilogue.  */
1680       cfun->function_end_locus = input_location;
1681
1682       /* We're leaving the context of this function, so zap cfun.
1683          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1684          tree_rest_of_compilation.  */
1685       cfun = NULL;
1686
1687       current_function_decl = NULL_TREE;
1688
1689       gfc_gimplify_function (thunk_fndecl);
1690       cgraph_finalize_function (thunk_fndecl, false);
1691
1692       /* We share the symbols in the formal argument list with other entry
1693          points and the master function.  Clear them so that they are
1694          recreated for each function.  */
1695       for (formal = thunk_sym->formal; formal; formal = formal->next)
1696         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1697           {
1698             formal->sym->backend_decl = NULL_TREE;
1699             if (formal->sym->ts.type == BT_CHARACTER)
1700               formal->sym->ts.cl->backend_decl = NULL_TREE;
1701           }
1702
1703       if (thunk_sym->attr.function)
1704         {
1705           if (thunk_sym->ts.type == BT_CHARACTER)
1706             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1707           if (thunk_sym->result->ts.type == BT_CHARACTER)
1708             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1709         }
1710     }
1711
1712   gfc_set_backend_locus (&old_loc);
1713 }
1714
1715
1716 /* Create a decl for a function, and create any thunks for alternate entry
1717    points.  */
1718
1719 void
1720 gfc_create_function_decl (gfc_namespace * ns)
1721 {
1722   /* Create a declaration for the master function.  */
1723   build_function_decl (ns->proc_name);
1724
1725   /* Compile the entry thunks.  */
1726   if (ns->entries)
1727     build_entry_thunks (ns);
1728
1729   /* Now create the read argument list.  */
1730   create_function_arglist (ns->proc_name);
1731 }
1732
1733 /* Return the decl used to hold the function return value.  */
1734
1735 tree
1736 gfc_get_fake_result_decl (gfc_symbol * sym)
1737 {
1738   tree decl, length;
1739
1740   char name[GFC_MAX_SYMBOL_LEN + 10];
1741
1742   if (sym
1743       && sym->ns->proc_name->backend_decl == current_function_decl
1744       && sym->ns->proc_name->attr.entry_master
1745       && sym != sym->ns->proc_name)
1746     {
1747       tree t = NULL, var;
1748       if (current_fake_result_decl != NULL)
1749         for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
1750           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1751             break;
1752       if (t)
1753         return TREE_VALUE (t);
1754       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1755       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1756         {
1757           tree field;
1758
1759           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1760                field; field = TREE_CHAIN (field))
1761             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1762                 sym->name) == 0)
1763               break;
1764
1765           gcc_assert (field != NULL_TREE);
1766           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1767                          NULL_TREE);
1768         }
1769       var = gfc_create_var (TREE_TYPE (decl), sym->name);
1770       GFC_DECL_RESULT (var) = 1;
1771       SET_DECL_VALUE_EXPR (var, decl);
1772       DECL_HAS_VALUE_EXPR_P (var) = 1;
1773       TREE_CHAIN (current_fake_result_decl)
1774         = tree_cons (get_identifier (sym->name), var,
1775                      TREE_CHAIN (current_fake_result_decl));
1776       return var;
1777     }
1778
1779   if (current_fake_result_decl != NULL_TREE)
1780     return TREE_VALUE (current_fake_result_decl);
1781
1782   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1783      sym is NULL.  */
1784   if (!sym)
1785     return NULL_TREE;
1786
1787   if (sym->ts.type == BT_CHARACTER)
1788     {
1789       if (sym->ts.cl->backend_decl == NULL_TREE)
1790         length = gfc_create_string_length (sym);
1791       else
1792         length = sym->ts.cl->backend_decl;
1793       if (TREE_CODE (length) == VAR_DECL
1794           && DECL_CONTEXT (length) == NULL_TREE)
1795         gfc_add_decl_to_function (length);
1796     }
1797
1798   if (gfc_return_by_reference (sym))
1799     {
1800       decl = DECL_ARGUMENTS (current_function_decl);
1801
1802       if (sym->ns->proc_name->backend_decl == current_function_decl
1803           && sym->ns->proc_name->attr.entry_master)
1804         decl = TREE_CHAIN (decl);
1805
1806       TREE_USED (decl) = 1;
1807       if (sym->as)
1808         decl = gfc_build_dummy_array_decl (sym, decl);
1809     }
1810   else
1811     {
1812       sprintf (name, "__result_%.20s",
1813                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1814
1815       decl = build_decl (VAR_DECL, get_identifier (name),
1816                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1817
1818       DECL_ARTIFICIAL (decl) = 1;
1819       DECL_EXTERNAL (decl) = 0;
1820       TREE_PUBLIC (decl) = 0;
1821       TREE_USED (decl) = 1;
1822       GFC_DECL_RESULT (decl) = 1;
1823
1824       layout_decl (decl, 0);
1825
1826       gfc_add_decl_to_function (decl);
1827     }
1828
1829   current_fake_result_decl = build_tree_list (NULL, decl);
1830
1831   return decl;
1832 }
1833
1834
1835 /* Builds a function decl.  The remaining parameters are the types of the
1836    function arguments.  Negative nargs indicates a varargs function.  */
1837
1838 tree
1839 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1840 {
1841   tree arglist;
1842   tree argtype;
1843   tree fntype;
1844   tree fndecl;
1845   va_list p;
1846   int n;
1847
1848   /* Library functions must be declared with global scope.  */
1849   gcc_assert (current_function_decl == NULL_TREE);
1850
1851   va_start (p, nargs);
1852
1853
1854   /* Create a list of the argument types.  */
1855   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1856     {
1857       argtype = va_arg (p, tree);
1858       arglist = gfc_chainon_list (arglist, argtype);
1859     }
1860
1861   if (nargs >= 0)
1862     {
1863       /* Terminate the list.  */
1864       arglist = gfc_chainon_list (arglist, void_type_node);
1865     }
1866
1867   /* Build the function type and decl.  */
1868   fntype = build_function_type (rettype, arglist);
1869   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1870
1871   /* Mark this decl as external.  */
1872   DECL_EXTERNAL (fndecl) = 1;
1873   TREE_PUBLIC (fndecl) = 1;
1874
1875   va_end (p);
1876
1877   pushdecl (fndecl);
1878
1879   rest_of_decl_compilation (fndecl, 1, 0);
1880
1881   return fndecl;
1882 }
1883
1884 static void
1885 gfc_build_intrinsic_function_decls (void)
1886 {
1887   tree gfc_int4_type_node = gfc_get_int_type (4);
1888   tree gfc_int8_type_node = gfc_get_int_type (8);
1889   tree gfc_int16_type_node = gfc_get_int_type (16);
1890   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1891   tree gfc_real4_type_node = gfc_get_real_type (4);
1892   tree gfc_real8_type_node = gfc_get_real_type (8);
1893   tree gfc_real10_type_node = gfc_get_real_type (10);
1894   tree gfc_real16_type_node = gfc_get_real_type (16);
1895   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1896   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1897   tree gfc_complex10_type_node = gfc_get_complex_type (10);
1898   tree gfc_complex16_type_node = gfc_get_complex_type (16);
1899   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1900
1901   /* String functions.  */
1902   gfor_fndecl_copy_string =
1903     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1904                                      void_type_node,
1905                                      4,
1906                                      gfc_charlen_type_node, pchar_type_node,
1907                                      gfc_charlen_type_node, pchar_type_node);
1908
1909   gfor_fndecl_compare_string =
1910     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1911                                      gfc_int4_type_node,
1912                                      4,
1913                                      gfc_charlen_type_node, pchar_type_node,
1914                                      gfc_charlen_type_node, pchar_type_node);
1915
1916   gfor_fndecl_concat_string =
1917     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1918                                      void_type_node,
1919                                      6,
1920                                      gfc_charlen_type_node, pchar_type_node,
1921                                      gfc_charlen_type_node, pchar_type_node,
1922                                      gfc_charlen_type_node, pchar_type_node);
1923
1924   gfor_fndecl_string_len_trim =
1925     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1926                                      gfc_int4_type_node,
1927                                      2, gfc_charlen_type_node,
1928                                      pchar_type_node);
1929
1930   gfor_fndecl_string_index =
1931     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1932                                      gfc_int4_type_node,
1933                                      5, gfc_charlen_type_node, pchar_type_node,
1934                                      gfc_charlen_type_node, pchar_type_node,
1935                                      gfc_logical4_type_node);
1936
1937   gfor_fndecl_string_scan =
1938     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1939                                      gfc_int4_type_node,
1940                                      5, gfc_charlen_type_node, pchar_type_node,
1941                                      gfc_charlen_type_node, pchar_type_node,
1942                                      gfc_logical4_type_node);
1943
1944   gfor_fndecl_string_verify =
1945     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1946                                      gfc_int4_type_node,
1947                                      5, gfc_charlen_type_node, pchar_type_node,
1948                                      gfc_charlen_type_node, pchar_type_node,
1949                                      gfc_logical4_type_node);
1950
1951   gfor_fndecl_string_trim =
1952     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1953                                      void_type_node,
1954                                      4,
1955                                      build_pointer_type (gfc_charlen_type_node),
1956                                      ppvoid_type_node,
1957                                      gfc_charlen_type_node,
1958                                      pchar_type_node);
1959
1960   gfor_fndecl_string_repeat =
1961     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1962                                      void_type_node,
1963                                      4,
1964                                      pchar_type_node,
1965                                      gfc_charlen_type_node,
1966                                      pchar_type_node,
1967                                      gfc_int4_type_node);
1968
1969   gfor_fndecl_ttynam =
1970     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
1971                                      void_type_node,
1972                                      3,
1973                                      pchar_type_node,
1974                                      gfc_charlen_type_node,
1975                                      gfc_c_int_type_node);
1976
1977   gfor_fndecl_fdate =
1978     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
1979                                      void_type_node,
1980                                      2,
1981                                      pchar_type_node,
1982                                      gfc_charlen_type_node);
1983
1984   gfor_fndecl_ctime =
1985     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
1986                                      void_type_node,
1987                                      3,
1988                                      pchar_type_node,
1989                                      gfc_charlen_type_node,
1990                                      gfc_int8_type_node);
1991
1992   gfor_fndecl_adjustl =
1993     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1994                                      void_type_node,
1995                                      3,
1996                                      pchar_type_node,
1997                                      gfc_charlen_type_node, pchar_type_node);
1998
1999   gfor_fndecl_adjustr =
2000     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2001                                      void_type_node,
2002                                      3,
2003                                      pchar_type_node,
2004                                      gfc_charlen_type_node, pchar_type_node);
2005
2006   gfor_fndecl_si_kind =
2007     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2008                                      gfc_int4_type_node,
2009                                      1,
2010                                      pvoid_type_node);
2011
2012   gfor_fndecl_sr_kind =
2013     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
2014                                      gfc_int4_type_node,
2015                                      2, pvoid_type_node,
2016                                      pvoid_type_node);
2017
2018   /* Power functions.  */
2019   {
2020     tree ctype, rtype, itype, jtype;
2021     int rkind, ikind, jkind;
2022 #define NIKINDS 3
2023 #define NRKINDS 4
2024     static int ikinds[NIKINDS] = {4, 8, 16};
2025     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2026     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2027
2028     for (ikind=0; ikind < NIKINDS; ikind++)
2029       {
2030         itype = gfc_get_int_type (ikinds[ikind]);
2031
2032         for (jkind=0; jkind < NIKINDS; jkind++)
2033           {
2034             jtype = gfc_get_int_type (ikinds[jkind]);
2035             if (itype && jtype)
2036               {
2037                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2038                         ikinds[jkind]);
2039                 gfor_fndecl_math_powi[jkind][ikind].integer =
2040                   gfc_build_library_function_decl (get_identifier (name),
2041                     jtype, 2, jtype, itype);
2042               }
2043           }
2044
2045         for (rkind = 0; rkind < NRKINDS; rkind ++)
2046           {
2047             rtype = gfc_get_real_type (rkinds[rkind]);
2048             if (rtype && itype)
2049               {
2050                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2051                         ikinds[ikind]);
2052                 gfor_fndecl_math_powi[rkind][ikind].real =
2053                   gfc_build_library_function_decl (get_identifier (name),
2054                     rtype, 2, rtype, itype);
2055               }
2056
2057             ctype = gfc_get_complex_type (rkinds[rkind]);
2058             if (ctype && itype)
2059               {
2060                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2061                         ikinds[ikind]);
2062                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2063                   gfc_build_library_function_decl (get_identifier (name),
2064                     ctype, 2,ctype, itype);
2065               }
2066           }
2067       }
2068 #undef NIKINDS
2069 #undef NRKINDS
2070   }
2071
2072   gfor_fndecl_math_cpowf =
2073     gfc_build_library_function_decl (get_identifier ("cpowf"),
2074                                      gfc_complex4_type_node,
2075                                      1, gfc_complex4_type_node);
2076   gfor_fndecl_math_cpow =
2077     gfc_build_library_function_decl (get_identifier ("cpow"),
2078                                      gfc_complex8_type_node,
2079                                      1, gfc_complex8_type_node);
2080   if (gfc_complex10_type_node)
2081     gfor_fndecl_math_cpowl10 =
2082       gfc_build_library_function_decl (get_identifier ("cpowl"),
2083                                        gfc_complex10_type_node, 1,
2084                                        gfc_complex10_type_node);
2085   if (gfc_complex16_type_node)
2086     gfor_fndecl_math_cpowl16 =
2087       gfc_build_library_function_decl (get_identifier ("cpowl"),
2088                                        gfc_complex16_type_node, 1,
2089                                        gfc_complex16_type_node);
2090
2091   gfor_fndecl_math_ishftc4 =
2092     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2093                                      gfc_int4_type_node,
2094                                      3, gfc_int4_type_node,
2095                                      gfc_int4_type_node, gfc_int4_type_node);
2096   gfor_fndecl_math_ishftc8 =
2097     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2098                                      gfc_int8_type_node,
2099                                      3, gfc_int8_type_node,
2100                                      gfc_int4_type_node, gfc_int4_type_node);
2101   if (gfc_int16_type_node)
2102     gfor_fndecl_math_ishftc16 =
2103       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2104                                        gfc_int16_type_node, 3,
2105                                        gfc_int16_type_node,
2106                                        gfc_int4_type_node,
2107                                        gfc_int4_type_node);
2108
2109   gfor_fndecl_math_exponent4 =
2110     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2111                                      gfc_int4_type_node,
2112                                      1, gfc_real4_type_node);
2113   gfor_fndecl_math_exponent8 =
2114     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2115                                      gfc_int4_type_node,
2116                                      1, gfc_real8_type_node);
2117   if (gfc_real10_type_node)
2118     gfor_fndecl_math_exponent10 =
2119       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2120                                        gfc_int4_type_node, 1,
2121                                        gfc_real10_type_node);
2122   if (gfc_real16_type_node)
2123     gfor_fndecl_math_exponent16 =
2124       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2125                                        gfc_int4_type_node, 1,
2126                                        gfc_real16_type_node);
2127
2128   /* Other functions.  */
2129   gfor_fndecl_size0 =
2130     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2131                                      gfc_array_index_type,
2132                                      1, pvoid_type_node);
2133   gfor_fndecl_size1 =
2134     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2135                                      gfc_array_index_type,
2136                                      2, pvoid_type_node,
2137                                      gfc_array_index_type);
2138
2139   gfor_fndecl_iargc =
2140     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2141                                      gfc_int4_type_node,
2142                                      0);
2143 }
2144
2145
2146 /* Make prototypes for runtime library functions.  */
2147
2148 void
2149 gfc_build_builtin_function_decls (void)
2150 {
2151   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2152   tree gfc_int4_type_node = gfc_get_int_type (4);
2153   tree gfc_int8_type_node = gfc_get_int_type (8);
2154   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2155   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2156
2157   /* Treat these two internal malloc wrappers as malloc.  */
2158   gfor_fndecl_internal_malloc =
2159     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2160                                      pvoid_type_node, 1, gfc_int4_type_node);
2161   DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
2162
2163   gfor_fndecl_internal_malloc64 =
2164     gfc_build_library_function_decl (get_identifier
2165                                      (PREFIX("internal_malloc64")),
2166                                      pvoid_type_node, 1, gfc_int8_type_node);
2167   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
2168
2169   gfor_fndecl_internal_realloc =
2170     gfc_build_library_function_decl (get_identifier
2171                                      (PREFIX("internal_realloc")),
2172                                      pvoid_type_node, 2, pvoid_type_node,
2173                                      gfc_int4_type_node);
2174
2175   gfor_fndecl_internal_realloc64 =
2176     gfc_build_library_function_decl (get_identifier
2177                                      (PREFIX("internal_realloc64")),
2178                                      pvoid_type_node, 2, pvoid_type_node,
2179                                      gfc_int8_type_node);
2180
2181   gfor_fndecl_internal_free =
2182     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2183                                      void_type_node, 1, pvoid_type_node);
2184
2185   gfor_fndecl_allocate =
2186     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2187                                      void_type_node, 2, ppvoid_type_node,
2188                                      gfc_int4_type_node);
2189
2190   gfor_fndecl_allocate64 =
2191     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2192                                      void_type_node, 2, ppvoid_type_node,
2193                                      gfc_int8_type_node);
2194
2195   gfor_fndecl_deallocate =
2196     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2197                                      void_type_node, 2, ppvoid_type_node,
2198                                      gfc_pint4_type_node);
2199
2200   gfor_fndecl_stop_numeric =
2201     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2202                                      void_type_node, 1, gfc_int4_type_node);
2203
2204   /* Stop doesn't return.  */
2205   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2206
2207   gfor_fndecl_stop_string =
2208     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2209                                      void_type_node, 2, pchar_type_node,
2210                                      gfc_int4_type_node);
2211   /* Stop doesn't return.  */
2212   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2213
2214   gfor_fndecl_pause_numeric =
2215     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2216                                      void_type_node, 1, gfc_int4_type_node);
2217
2218   gfor_fndecl_pause_string =
2219     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2220                                      void_type_node, 2, pchar_type_node,
2221                                      gfc_int4_type_node);
2222
2223   gfor_fndecl_select_string =
2224     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2225                                      pvoid_type_node, 0);
2226
2227   gfor_fndecl_runtime_error =
2228     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2229                                      void_type_node,
2230                                      3,
2231                                      pchar_type_node, pchar_type_node,
2232                                      gfc_int4_type_node);
2233   /* The runtime_error function does not return.  */
2234   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2235
2236   gfor_fndecl_set_fpe =
2237     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2238                                     void_type_node, 1, gfc_c_int_type_node);
2239
2240   gfor_fndecl_set_std =
2241     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2242                                     void_type_node,
2243                                     3,
2244                                     gfc_int4_type_node,
2245                                     gfc_int4_type_node,
2246                                     gfc_int4_type_node);
2247
2248   gfor_fndecl_set_convert =
2249     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2250                                      void_type_node, 1, gfc_c_int_type_node);
2251
2252   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2253         get_identifier (PREFIX("internal_pack")),
2254         pvoid_type_node, 1, pvoid_type_node);
2255
2256   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2257         get_identifier (PREFIX("internal_unpack")),
2258         pvoid_type_node, 1, pvoid_type_node);
2259
2260   gfor_fndecl_associated =
2261     gfc_build_library_function_decl (
2262                                      get_identifier (PREFIX("associated")),
2263                                      gfc_logical4_type_node,
2264                                      2,
2265                                      ppvoid_type_node,
2266                                      ppvoid_type_node);
2267
2268   gfc_build_intrinsic_function_decls ();
2269   gfc_build_intrinsic_lib_fndecls ();
2270   gfc_build_io_library_fndecls ();
2271 }
2272
2273
2274 /* Evaluate the length of dummy character variables.  */
2275
2276 static tree
2277 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2278 {
2279   stmtblock_t body;
2280
2281   gfc_finish_decl (cl->backend_decl, NULL_TREE);
2282
2283   gfc_start_block (&body);
2284
2285   /* Evaluate the string length expression.  */
2286   gfc_trans_init_string_length (cl, &body);
2287
2288   gfc_trans_vla_type_sizes (sym, &body);
2289
2290   gfc_add_expr_to_block (&body, fnbody);
2291   return gfc_finish_block (&body);
2292 }
2293
2294
2295 /* Allocate and cleanup an automatic character variable.  */
2296
2297 static tree
2298 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2299 {
2300   stmtblock_t body;
2301   tree decl;
2302   tree tmp;
2303
2304   gcc_assert (sym->backend_decl);
2305   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2306
2307   gfc_start_block (&body);
2308
2309   /* Evaluate the string length expression.  */
2310   gfc_trans_init_string_length (sym->ts.cl, &body);
2311
2312   gfc_trans_vla_type_sizes (sym, &body);
2313
2314   decl = sym->backend_decl;
2315
2316   /* Emit a DECL_EXPR for this variable, which will cause the
2317      gimplifier to allocate storage, and all that good stuff.  */
2318   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2319   gfc_add_expr_to_block (&body, tmp);
2320
2321   gfc_add_expr_to_block (&body, fnbody);
2322   return gfc_finish_block (&body);
2323 }
2324
2325 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2326
2327 static tree
2328 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2329 {
2330   stmtblock_t body;
2331
2332   gcc_assert (sym->backend_decl);
2333   gfc_start_block (&body);
2334
2335   /* Set the initial value to length. See the comments in
2336      function gfc_add_assign_aux_vars in this file.  */
2337   gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2338                        build_int_cst (NULL_TREE, -2));
2339
2340   gfc_add_expr_to_block (&body, fnbody);
2341   return gfc_finish_block (&body);
2342 }
2343
2344 static void
2345 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2346 {
2347   tree t = *tp, var, val;
2348
2349   if (t == NULL || t == error_mark_node)
2350     return;
2351   if (TREE_CONSTANT (t) || DECL_P (t))
2352     return;
2353
2354   if (TREE_CODE (t) == SAVE_EXPR)
2355     {
2356       if (SAVE_EXPR_RESOLVED_P (t))
2357         {
2358           *tp = TREE_OPERAND (t, 0);
2359           return;
2360         }
2361       val = TREE_OPERAND (t, 0);
2362     }
2363   else
2364     val = t;
2365
2366   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2367   gfc_add_decl_to_function (var);
2368   gfc_add_modify_expr (body, var, val);
2369   if (TREE_CODE (t) == SAVE_EXPR)
2370     TREE_OPERAND (t, 0) = var;
2371   *tp = var;
2372 }
2373
2374 static void
2375 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2376 {
2377   tree t;
2378
2379   if (type == NULL || type == error_mark_node)
2380     return;
2381
2382   type = TYPE_MAIN_VARIANT (type);
2383
2384   if (TREE_CODE (type) == INTEGER_TYPE)
2385     {
2386       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2387       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2388
2389       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2390         {
2391           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2392           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2393         }
2394     }
2395   else if (TREE_CODE (type) == ARRAY_TYPE)
2396     {
2397       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2398       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2399       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2400       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2401
2402       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2403         {
2404           TYPE_SIZE (t) = TYPE_SIZE (type);
2405           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2406         }
2407     }
2408 }
2409
2410 /* Make sure all type sizes and array domains are either constant,
2411    or variable or parameter decls.  This is a simplified variant
2412    of gimplify_type_sizes, but we can't use it here, as none of the
2413    variables in the expressions have been gimplified yet.
2414    As type sizes and domains for various variable length arrays
2415    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2416    time, without this routine gimplify_type_sizes in the middle-end
2417    could result in the type sizes being gimplified earlier than where
2418    those variables are initialized.  */
2419
2420 void
2421 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2422 {
2423   tree type = TREE_TYPE (sym->backend_decl);
2424
2425   if (TREE_CODE (type) == FUNCTION_TYPE
2426       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2427     {
2428       if (! current_fake_result_decl)
2429         return;
2430
2431       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2432     }
2433
2434   while (POINTER_TYPE_P (type))
2435     type = TREE_TYPE (type);
2436
2437   if (GFC_DESCRIPTOR_TYPE_P (type))
2438     {
2439       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2440
2441       while (POINTER_TYPE_P (etype))
2442         etype = TREE_TYPE (etype);
2443
2444       gfc_trans_vla_type_sizes_1 (etype, body);
2445     }
2446
2447   gfc_trans_vla_type_sizes_1 (type, body);
2448 }
2449
2450
2451 /* Generate function entry and exit code, and add it to the function body.
2452    This includes:
2453     Allocation and initialization of array variables.
2454     Allocation of character string variables.
2455     Initialization and possibly repacking of dummy arrays.
2456     Initialization of ASSIGN statement auxiliary variable.  */
2457
2458 static tree
2459 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2460 {
2461   locus loc;
2462   gfc_symbol *sym;
2463   gfc_formal_arglist *f;
2464   stmtblock_t body;
2465
2466   /* Deal with implicit return variables.  Explicit return variables will
2467      already have been added.  */
2468   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2469     {
2470       if (!current_fake_result_decl)
2471         {
2472           gfc_entry_list *el = NULL;
2473           if (proc_sym->attr.entry_master)
2474             {
2475               for (el = proc_sym->ns->entries; el; el = el->next)
2476                 if (el->sym != el->sym->result)
2477                   break;
2478             }
2479           if (el == NULL)
2480             warning (0, "Function does not return a value");
2481         }
2482       else if (proc_sym->as)
2483         {
2484           tree result = TREE_VALUE (current_fake_result_decl);
2485           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2486         }
2487       else if (proc_sym->ts.type == BT_CHARACTER)
2488         {
2489           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2490             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2491                                                 fnbody);
2492         }
2493       else
2494         gcc_assert (gfc_option.flag_f2c
2495                     && proc_sym->ts.type == BT_COMPLEX);
2496     }
2497
2498   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2499     {
2500       if (sym->attr.dimension)
2501         {
2502           switch (sym->as->type)
2503             {
2504             case AS_EXPLICIT:
2505               if (sym->attr.dummy || sym->attr.result)
2506                 fnbody =
2507                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2508               else if (sym->attr.pointer || sym->attr.allocatable)
2509                 {
2510                   if (TREE_STATIC (sym->backend_decl))
2511                     gfc_trans_static_array_pointer (sym);
2512                   else
2513                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2514                 }
2515               else
2516                 {
2517                   gfc_get_backend_locus (&loc);
2518                   gfc_set_backend_locus (&sym->declared_at);
2519                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2520                       sym, fnbody);
2521                   gfc_set_backend_locus (&loc);
2522                 }
2523               break;
2524
2525             case AS_ASSUMED_SIZE:
2526               /* Must be a dummy parameter.  */
2527               gcc_assert (sym->attr.dummy);
2528
2529               /* We should always pass assumed size arrays the g77 way.  */
2530               fnbody = gfc_trans_g77_array (sym, fnbody);
2531               break;
2532
2533             case AS_ASSUMED_SHAPE:
2534               /* Must be a dummy parameter.  */
2535               gcc_assert (sym->attr.dummy);
2536
2537               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2538                                                    fnbody);
2539               break;
2540
2541             case AS_DEFERRED:
2542               fnbody = gfc_trans_deferred_array (sym, fnbody);
2543               break;
2544
2545             default:
2546               gcc_unreachable ();
2547             }
2548         }
2549       else if (sym->ts.type == BT_CHARACTER)
2550         {
2551           gfc_get_backend_locus (&loc);
2552           gfc_set_backend_locus (&sym->declared_at);
2553           if (sym->attr.dummy || sym->attr.result)
2554             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2555           else
2556             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2557           gfc_set_backend_locus (&loc);
2558         }
2559       else if (sym->attr.assign)
2560         {
2561           gfc_get_backend_locus (&loc);
2562           gfc_set_backend_locus (&sym->declared_at);
2563           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2564           gfc_set_backend_locus (&loc);
2565         }
2566       else
2567         gcc_unreachable ();
2568     }
2569
2570   gfc_init_block (&body);
2571
2572   for (f = proc_sym->formal; f; f = f->next)
2573     if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2574       {
2575         gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2576         if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2577           gfc_trans_vla_type_sizes (f->sym, &body);
2578       }
2579
2580   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2581       && current_fake_result_decl != NULL)
2582     {
2583       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2584       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2585         gfc_trans_vla_type_sizes (proc_sym, &body);
2586     }
2587
2588   gfc_add_expr_to_block (&body, fnbody);
2589   return gfc_finish_block (&body);
2590 }
2591
2592
2593 /* Output an initialized decl for a module variable.  */
2594
2595 static void
2596 gfc_create_module_variable (gfc_symbol * sym)
2597 {
2598   tree decl;
2599
2600   /* Only output symbols from this module.  */
2601   if (sym->ns != module_namespace)
2602     {
2603       /* I don't think this should ever happen.  */
2604       internal_error ("module symbol %s in wrong namespace", sym->name);
2605     }
2606
2607   /* Only output variables and array valued parameters.  */
2608   if (sym->attr.flavor != FL_VARIABLE
2609       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2610     return;
2611
2612   /* Don't generate variables from other modules. Variables from
2613      COMMONs will already have been generated.  */
2614   if (sym->attr.use_assoc || sym->attr.in_common)
2615     return;
2616
2617   /* Equivalenced variables arrive here after creation.  */
2618   if (sym->backend_decl
2619         && (sym->equiv_built || sym->attr.in_equivalence))
2620       return;
2621
2622   if (sym->backend_decl)
2623     internal_error ("backend decl for module variable %s already exists",
2624                     sym->name);
2625
2626   /* We always want module variables to be created.  */
2627   sym->attr.referenced = 1;
2628   /* Create the decl.  */
2629   decl = gfc_get_symbol_decl (sym);
2630
2631   /* Create the variable.  */
2632   pushdecl (decl);
2633   rest_of_decl_compilation (decl, 1, 0);
2634
2635   /* Also add length of strings.  */
2636   if (sym->ts.type == BT_CHARACTER)
2637     {
2638       tree length;
2639
2640       length = sym->ts.cl->backend_decl;
2641       if (!INTEGER_CST_P (length))
2642         {
2643           pushdecl (length);
2644           rest_of_decl_compilation (length, 1, 0);
2645         }
2646     }
2647 }
2648
2649
2650 /* Generate all the required code for module variables.  */
2651
2652 void
2653 gfc_generate_module_vars (gfc_namespace * ns)
2654 {
2655   module_namespace = ns;
2656
2657   /* Check if the frontend left the namespace in a reasonable state.  */
2658   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2659
2660   /* Generate COMMON blocks.  */
2661   gfc_trans_common (ns);
2662
2663   /* Create decls for all the module variables.  */
2664   gfc_traverse_ns (ns, gfc_create_module_variable);
2665 }
2666
2667 static void
2668 gfc_generate_contained_functions (gfc_namespace * parent)
2669 {
2670   gfc_namespace *ns;
2671
2672   /* We create all the prototypes before generating any code.  */
2673   for (ns = parent->contained; ns; ns = ns->sibling)
2674     {
2675       /* Skip namespaces from used modules.  */
2676       if (ns->parent != parent)
2677         continue;
2678
2679       gfc_create_function_decl (ns);
2680     }
2681
2682   for (ns = parent->contained; ns; ns = ns->sibling)
2683     {
2684       /* Skip namespaces from used modules.  */
2685       if (ns->parent != parent)
2686         continue;
2687
2688       gfc_generate_function_code (ns);
2689     }
2690 }
2691
2692
2693 /* Generate decls for all local variables.  We do this to ensure correct
2694    handling of expressions which only appear in the specification of
2695    other functions.  */
2696
2697 static void
2698 generate_local_decl (gfc_symbol * sym)
2699 {
2700   if (sym->attr.flavor == FL_VARIABLE)
2701     {
2702       if (sym->attr.referenced)
2703         gfc_get_symbol_decl (sym);
2704       else if (sym->attr.dummy && warn_unused_parameter)
2705             warning (0, "unused parameter %qs", sym->name);
2706       /* Warn for unused variables, but not if they're inside a common
2707          block or are use-associated.  */
2708       else if (warn_unused_variable
2709                && !(sym->attr.in_common || sym->attr.use_assoc))
2710         warning (0, "unused variable %qs", sym->name);
2711       /* For variable length CHARACTER parameters, the PARM_DECL already
2712          references the length variable, so force gfc_get_symbol_decl
2713          even when not referenced.  If optimize > 0, it will be optimized
2714          away anyway.  But do this only after emitting -Wunused-parameter
2715          warning if requested.  */
2716       if (sym->attr.dummy && ! sym->attr.referenced
2717           && sym->ts.type == BT_CHARACTER
2718           && sym->ts.cl->backend_decl != NULL
2719           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2720         {
2721           sym->attr.referenced = 1;
2722           gfc_get_symbol_decl (sym);
2723         }
2724     }
2725 }
2726
2727 static void
2728 generate_local_vars (gfc_namespace * ns)
2729 {
2730   gfc_traverse_ns (ns, generate_local_decl);
2731 }
2732
2733
2734 /* Generate a switch statement to jump to the correct entry point.  Also
2735    creates the label decls for the entry points.  */
2736
2737 static tree
2738 gfc_trans_entry_master_switch (gfc_entry_list * el)
2739 {
2740   stmtblock_t block;
2741   tree label;
2742   tree tmp;
2743   tree val;
2744
2745   gfc_init_block (&block);
2746   for (; el; el = el->next)
2747     {
2748       /* Add the case label.  */
2749       label = gfc_build_label_decl (NULL_TREE);
2750       val = build_int_cst (gfc_array_index_type, el->id);
2751       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2752       gfc_add_expr_to_block (&block, tmp);
2753
2754       /* And jump to the actual entry point.  */
2755       label = gfc_build_label_decl (NULL_TREE);
2756       tmp = build1_v (GOTO_EXPR, label);
2757       gfc_add_expr_to_block (&block, tmp);
2758
2759       /* Save the label decl.  */
2760       el->label = label;
2761     }
2762   tmp = gfc_finish_block (&block);
2763   /* The first argument selects the entry point.  */
2764   val = DECL_ARGUMENTS (current_function_decl);
2765   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2766   return tmp;
2767 }
2768
2769
2770 /* Generate code for a function.  */
2771
2772 void
2773 gfc_generate_function_code (gfc_namespace * ns)
2774 {
2775   tree fndecl;
2776   tree old_context;
2777   tree decl;
2778   tree tmp;
2779   stmtblock_t block;
2780   stmtblock_t body;
2781   tree result;
2782   gfc_symbol *sym;
2783
2784   sym = ns->proc_name;
2785
2786   /* Check that the frontend isn't still using this.  */
2787   gcc_assert (sym->tlink == NULL);
2788   sym->tlink = sym;
2789
2790   /* Create the declaration for functions with global scope.  */
2791   if (!sym->backend_decl)
2792     gfc_create_function_decl (ns);
2793
2794   fndecl = sym->backend_decl;
2795   old_context = current_function_decl;
2796
2797   if (old_context)
2798     {
2799       push_function_context ();
2800       saved_parent_function_decls = saved_function_decls;
2801       saved_function_decls = NULL_TREE;
2802     }
2803
2804   trans_function_start (sym);
2805
2806   gfc_start_block (&block);
2807
2808   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2809     {
2810       /* Copy length backend_decls to all entry point result
2811          symbols.  */
2812       gfc_entry_list *el;
2813       tree backend_decl;
2814
2815       gfc_conv_const_charlen (ns->proc_name->ts.cl);
2816       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2817       for (el = ns->entries; el; el = el->next)
2818         el->sym->result->ts.cl->backend_decl = backend_decl;
2819     }
2820
2821   /* Translate COMMON blocks.  */
2822   gfc_trans_common (ns);
2823
2824   gfc_generate_contained_functions (ns);
2825
2826   generate_local_vars (ns);
2827
2828   /* Will be created as needed.  */
2829   current_fake_result_decl = NULL_TREE;
2830   current_function_return_label = NULL;
2831
2832   /* Now generate the code for the body of this function.  */
2833   gfc_init_block (&body);
2834
2835   /* If this is the main program, add a call to set_std to set up the
2836      runtime library Fortran language standard parameters.  */
2837
2838   if (sym->attr.is_main_program)
2839     {
2840       tree arglist, gfc_int4_type_node;
2841
2842       gfc_int4_type_node = gfc_get_int_type (4);
2843       arglist = gfc_chainon_list (NULL_TREE,
2844                                   build_int_cst (gfc_int4_type_node,
2845                                                  gfc_option.warn_std));
2846       arglist = gfc_chainon_list (arglist,
2847                                   build_int_cst (gfc_int4_type_node,
2848                                                  gfc_option.allow_std));
2849       arglist = gfc_chainon_list (arglist,
2850                                   build_int_cst (gfc_int4_type_node,
2851                                                  pedantic));
2852       tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
2853       gfc_add_expr_to_block (&body, tmp);
2854     }
2855
2856   /* If this is the main program and a -ffpe-trap option was provided,
2857      add a call to set_fpe so that the library will raise a FPE when
2858      needed.  */
2859   if (sym->attr.is_main_program && gfc_option.fpe != 0)
2860     {
2861       tree arglist, gfc_c_int_type_node;
2862
2863       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2864       arglist = gfc_chainon_list (NULL_TREE,
2865                                   build_int_cst (gfc_c_int_type_node,
2866                                                  gfc_option.fpe));
2867       tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
2868       gfc_add_expr_to_block (&body, tmp);
2869     }
2870
2871   /* If this is the main program and an -fconvert option was provided,
2872      add a call to set_convert.  */
2873
2874   if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
2875     {
2876       tree arglist, gfc_c_int_type_node;
2877
2878       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2879       arglist = gfc_chainon_list (NULL_TREE,
2880                                   build_int_cst (gfc_c_int_type_node,
2881                                                  gfc_option.convert));
2882       tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
2883       gfc_add_expr_to_block (&body, tmp);
2884     }
2885
2886
2887   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2888       && sym->attr.subroutine)
2889     {
2890       tree alternate_return;
2891       alternate_return = gfc_get_fake_result_decl (sym);
2892       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2893     }
2894
2895   if (ns->entries)
2896     {
2897       /* Jump to the correct entry point.  */
2898       tmp = gfc_trans_entry_master_switch (ns->entries);
2899       gfc_add_expr_to_block (&body, tmp);
2900     }
2901
2902   tmp = gfc_trans_code (ns->code);
2903   gfc_add_expr_to_block (&body, tmp);
2904
2905   /* Add a return label if needed.  */
2906   if (current_function_return_label)
2907     {
2908       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2909       gfc_add_expr_to_block (&body, tmp);
2910     }
2911
2912   tmp = gfc_finish_block (&body);
2913   /* Add code to create and cleanup arrays.  */
2914   tmp = gfc_trans_deferred_vars (sym, tmp);
2915   gfc_add_expr_to_block (&block, tmp);
2916
2917   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2918     {
2919       if (sym->attr.subroutine || sym == sym->result)
2920         {
2921           if (current_fake_result_decl != NULL)
2922             result = TREE_VALUE (current_fake_result_decl);
2923           else
2924             result = NULL_TREE;
2925           current_fake_result_decl = NULL_TREE;
2926         }
2927       else
2928         result = sym->result->backend_decl;
2929
2930       if (result == NULL_TREE)
2931         warning (0, "Function return value not set");
2932       else
2933         {
2934           /* Set the return value to the dummy result variable.  */
2935           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2936                         DECL_RESULT (fndecl), result);
2937           tmp = build1_v (RETURN_EXPR, tmp);
2938           gfc_add_expr_to_block (&block, tmp);
2939         }
2940     }
2941
2942   /* Add all the decls we created during processing.  */
2943   decl = saved_function_decls;
2944   while (decl)
2945     {
2946       tree next;
2947
2948       next = TREE_CHAIN (decl);
2949       TREE_CHAIN (decl) = NULL_TREE;
2950       pushdecl (decl);
2951       decl = next;
2952     }
2953   saved_function_decls = NULL_TREE;
2954
2955   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2956
2957   /* Finish off this function and send it for code generation.  */
2958   poplevel (1, 0, 1);
2959   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2960
2961   /* Output the GENERIC tree.  */
2962   dump_function (TDI_original, fndecl);
2963
2964   /* Store the end of the function, so that we get good line number
2965      info for the epilogue.  */
2966   cfun->function_end_locus = input_location;
2967
2968   /* We're leaving the context of this function, so zap cfun.
2969      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2970      tree_rest_of_compilation.  */
2971   cfun = NULL;
2972
2973   if (old_context)
2974     {
2975       pop_function_context ();
2976       saved_function_decls = saved_parent_function_decls;
2977     }
2978   current_function_decl = old_context;
2979
2980   if (decl_function_context (fndecl))
2981     /* Register this function with cgraph just far enough to get it
2982        added to our parent's nested function list.  */
2983     (void) cgraph_node (fndecl);
2984   else
2985     {
2986       gfc_gimplify_function (fndecl);
2987       cgraph_finalize_function (fndecl, false);
2988     }
2989 }
2990
2991 void
2992 gfc_generate_constructors (void)
2993 {
2994   gcc_assert (gfc_static_ctors == NULL_TREE);
2995 #if 0
2996   tree fnname;
2997   tree type;
2998   tree fndecl;
2999   tree decl;
3000   tree tmp;
3001
3002   if (gfc_static_ctors == NULL_TREE)
3003     return;
3004
3005   fnname = get_file_function_name ('I');
3006   type = build_function_type (void_type_node,
3007                               gfc_chainon_list (NULL_TREE, void_type_node));
3008
3009   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3010   TREE_PUBLIC (fndecl) = 1;
3011
3012   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3013   DECL_ARTIFICIAL (decl) = 1;
3014   DECL_IGNORED_P (decl) = 1;
3015   DECL_CONTEXT (decl) = fndecl;
3016   DECL_RESULT (fndecl) = decl;
3017
3018   pushdecl (fndecl);
3019
3020   current_function_decl = fndecl;
3021
3022   rest_of_decl_compilation (fndecl, 1, 0);
3023
3024   make_decl_rtl (fndecl);
3025
3026   init_function_start (fndecl);
3027
3028   pushlevel (0);
3029
3030   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3031     {
3032       tmp =
3033         build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
3034       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3035     }
3036
3037   poplevel (1, 0, 1);
3038
3039   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3040
3041   free_after_parsing (cfun);
3042   free_after_compilation (cfun);
3043
3044   tree_rest_of_compilation (fndecl);
3045
3046   current_function_decl = NULL_TREE;
3047 #endif
3048 }
3049
3050 /* Translates a BLOCK DATA program unit. This means emitting the
3051    commons contained therein plus their initializations. We also emit
3052    a globally visible symbol to make sure that each BLOCK DATA program
3053    unit remains unique.  */
3054
3055 void
3056 gfc_generate_block_data (gfc_namespace * ns)
3057 {
3058   tree decl;
3059   tree id;
3060
3061   /* Tell the backend the source location of the block data.  */
3062   if (ns->proc_name)
3063     gfc_set_backend_locus (&ns->proc_name->declared_at);
3064   else
3065     gfc_set_backend_locus (&gfc_current_locus);
3066
3067   /* Process the DATA statements.  */
3068   gfc_trans_common (ns);
3069
3070   /* Create a global symbol with the mane of the block data.  This is to
3071      generate linker errors if the same name is used twice.  It is never
3072      really used.  */
3073   if (ns->proc_name)
3074     id = gfc_sym_mangled_function_id (ns->proc_name);
3075   else
3076     id = get_identifier ("__BLOCK_DATA__");
3077
3078   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3079   TREE_PUBLIC (decl) = 1;
3080   TREE_STATIC (decl) = 1;
3081
3082   pushdecl (decl);
3083   rest_of_decl_compilation (decl, 1, 0);
3084 }
3085
3086
3087 #include "gt-fortran-trans-decl.h"