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