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