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