gcc/fortran/trans-decl.c

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