gcc/fortran/trans-decl.c

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