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