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   /* Layout the function declaration and put it in the binding level
1325      of the current function.  */
1326   pushdecl (fndecl);
1327
1328   sym->backend_decl = fndecl;
1329 }
1330
1331
1332 /* Create the DECL_ARGUMENTS for a procedure.  */
1333
1334 static void
1335 create_function_arglist (gfc_symbol * sym)
1336 {
1337   tree fndecl;
1338   gfc_formal_arglist *f;
1339   tree typelist, hidden_typelist;
1340   tree arglist, hidden_arglist;
1341   tree type;
1342   tree parm;
1343
1344   fndecl = sym->backend_decl;
1345
1346   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1347      the new FUNCTION_DECL node.  */
1348   arglist = NULL_TREE;
1349   hidden_arglist = NULL_TREE;
1350   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1351
1352   if (sym->attr.entry_master)
1353     {
1354       type = TREE_VALUE (typelist);
1355       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1356
1357       DECL_CONTEXT (parm) = fndecl;
1358       DECL_ARG_TYPE (parm) = type;
1359       TREE_READONLY (parm) = 1;
1360       gfc_finish_decl (parm);
1361       DECL_ARTIFICIAL (parm) = 1;
1362
1363       arglist = chainon (arglist, parm);
1364       typelist = TREE_CHAIN (typelist);
1365     }
1366
1367   if (gfc_return_by_reference (sym))
1368     {
1369       tree type = TREE_VALUE (typelist), length = NULL;
1370
1371       if (sym->ts.type == BT_CHARACTER)
1372         {
1373           /* Length of character result.  */
1374           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1375           gcc_assert (len_type == gfc_charlen_type_node);
1376
1377           length = build_decl (PARM_DECL,
1378                                get_identifier (".__result"),
1379                                len_type);
1380           if (!sym->ts.cl->length)
1381             {
1382               sym->ts.cl->backend_decl = length;
1383               TREE_USED (length) = 1;
1384             }
1385           gcc_assert (TREE_CODE (length) == PARM_DECL);
1386           DECL_CONTEXT (length) = fndecl;
1387           DECL_ARG_TYPE (length) = len_type;
1388           TREE_READONLY (length) = 1;
1389           DECL_ARTIFICIAL (length) = 1;
1390           gfc_finish_decl (length);
1391           if (sym->ts.cl->backend_decl == NULL
1392               || sym->ts.cl->backend_decl == length)
1393             {
1394               gfc_symbol *arg;
1395               tree backend_decl;
1396
1397               if (sym->ts.cl->backend_decl == NULL)
1398                 {
1399                   tree len = build_decl (VAR_DECL,
1400                                          get_identifier ("..__result"),
1401                                          gfc_charlen_type_node);
1402                   DECL_ARTIFICIAL (len) = 1;
1403                   TREE_USED (len) = 1;
1404                   sym->ts.cl->backend_decl = len;
1405                 }
1406
1407               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1408               arg = sym->result ? sym->result : sym;
1409               backend_decl = arg->backend_decl;
1410               /* Temporary clear it, so that gfc_sym_type creates complete
1411                  type.  */
1412               arg->backend_decl = NULL;
1413               type = gfc_sym_type (arg);
1414               arg->backend_decl = backend_decl;
1415               type = build_reference_type (type);
1416             }
1417         }
1418
1419       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1420
1421       DECL_CONTEXT (parm) = fndecl;
1422       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1423       TREE_READONLY (parm) = 1;
1424       DECL_ARTIFICIAL (parm) = 1;
1425       gfc_finish_decl (parm);
1426
1427       arglist = chainon (arglist, parm);
1428       typelist = TREE_CHAIN (typelist);
1429
1430       if (sym->ts.type == BT_CHARACTER)
1431         {
1432           gfc_allocate_lang_decl (parm);
1433           arglist = chainon (arglist, length);
1434           typelist = TREE_CHAIN (typelist);
1435         }
1436     }
1437
1438   hidden_typelist = typelist;
1439   for (f = sym->formal; f; f = f->next)
1440     if (f->sym != NULL) /* Ignore alternate returns.  */
1441       hidden_typelist = TREE_CHAIN (hidden_typelist);
1442
1443   for (f = sym->formal; f; f = f->next)
1444     {
1445       char name[GFC_MAX_SYMBOL_LEN + 2];
1446
1447       /* Ignore alternate returns.  */
1448       if (f->sym == NULL)
1449         continue;
1450
1451       type = TREE_VALUE (typelist);
1452
1453       if (f->sym->ts.type == BT_CHARACTER)
1454         {
1455           tree len_type = TREE_VALUE (hidden_typelist);
1456           tree length = NULL_TREE;
1457           gcc_assert (len_type == gfc_charlen_type_node);
1458
1459           strcpy (&name[1], f->sym->name);
1460           name[0] = '_';
1461           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1462
1463           hidden_arglist = chainon (hidden_arglist, length);
1464           DECL_CONTEXT (length) = fndecl;
1465           DECL_ARTIFICIAL (length) = 1;
1466           DECL_ARG_TYPE (length) = len_type;
1467           TREE_READONLY (length) = 1;
1468           gfc_finish_decl (length);
1469
1470           /* TODO: Check string lengths when -fbounds-check.  */
1471
1472           /* Use the passed value for assumed length variables.  */
1473           if (!f->sym->ts.cl->length)
1474             {
1475               TREE_USED (length) = 1;
1476               gcc_assert (!f->sym->ts.cl->backend_decl);
1477               f->sym->ts.cl->backend_decl = length;
1478             }
1479
1480           hidden_typelist = TREE_CHAIN (hidden_typelist);
1481
1482           if (f->sym->ts.cl->backend_decl == NULL
1483               || f->sym->ts.cl->backend_decl == length)
1484             {
1485               if (f->sym->ts.cl->backend_decl == NULL)
1486                 gfc_create_string_length (f->sym);
1487
1488               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1489               if (f->sym->attr.flavor == FL_PROCEDURE)
1490                 type = build_pointer_type (gfc_get_function_type (f->sym));
1491               else
1492                 type = gfc_sym_type (f->sym);
1493             }
1494         }
1495
1496       /* For non-constant length array arguments, make sure they use
1497          a different type node from TYPE_ARG_TYPES type.  */
1498       if (f->sym->attr.dimension
1499           && type == TREE_VALUE (typelist)
1500           && TREE_CODE (type) == POINTER_TYPE
1501           && GFC_ARRAY_TYPE_P (type)
1502           && f->sym->as->type != AS_ASSUMED_SIZE
1503           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1504         {
1505           if (f->sym->attr.flavor == FL_PROCEDURE)
1506             type = build_pointer_type (gfc_get_function_type (f->sym));
1507           else
1508             type = gfc_sym_type (f->sym);
1509         }
1510
1511       /* Build a the argument declaration.  */
1512       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1513
1514       /* Fill in arg stuff.  */
1515       DECL_CONTEXT (parm) = fndecl;
1516       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1517       /* All implementation args are read-only.  */
1518       TREE_READONLY (parm) = 1;
1519
1520       gfc_finish_decl (parm);
1521
1522       f->sym->backend_decl = parm;
1523
1524       arglist = chainon (arglist, parm);
1525       typelist = TREE_CHAIN (typelist);
1526     }
1527
1528   /* Add the hidden string length parameters.  */
1529   arglist = chainon (arglist, hidden_arglist);
1530
1531   gcc_assert (hidden_typelist == NULL_TREE
1532               || TREE_VALUE (hidden_typelist) == void_type_node);
1533   DECL_ARGUMENTS (fndecl) = arglist;
1534 }
1535
1536 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1537
1538 static void
1539 gfc_gimplify_function (tree fndecl)
1540 {
1541   struct cgraph_node *cgn;
1542
1543   gimplify_function_tree (fndecl);
1544   dump_function (TDI_generic, fndecl);
1545
1546   /* Generate errors for structured block violations.  */
1547   /* ??? Could be done as part of resolve_labels.  */
1548   if (flag_openmp)
1549     diagnose_omp_structured_block_errors (fndecl);
1550
1551   /* Convert all nested functions to GIMPLE now.  We do things in this order
1552      so that items like VLA sizes are expanded properly in the context of the
1553      correct function.  */
1554   cgn = cgraph_node (fndecl);
1555   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1556     gfc_gimplify_function (cgn->decl);
1557 }
1558
1559
1560 /* Do the setup necessary before generating the body of a function.  */
1561
1562 static void
1563 trans_function_start (gfc_symbol * sym)
1564 {
1565   tree fndecl;
1566
1567   fndecl = sym->backend_decl;
1568
1569   /* Let GCC know the current scope is this function.  */
1570   current_function_decl = fndecl;
1571
1572   /* Let the world know what we're about to do.  */
1573   announce_function (fndecl);
1574
1575   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1576     {
1577       /* Create RTL for function declaration.  */
1578       rest_of_decl_compilation (fndecl, 1, 0);
1579     }
1580
1581   /* Create RTL for function definition.  */
1582   make_decl_rtl (fndecl);
1583
1584   init_function_start (fndecl);
1585
1586   /* Even though we're inside a function body, we still don't want to
1587      call expand_expr to calculate the size of a variable-sized array.
1588      We haven't necessarily assigned RTL to all variables yet, so it's
1589      not safe to try to expand expressions involving them.  */
1590   cfun->x_dont_save_pending_sizes_p = 1;
1591
1592   /* function.c requires a push at the start of the function.  */
1593   pushlevel (0);
1594 }
1595
1596 /* Create thunks for alternate entry points.  */
1597
1598 static void
1599 build_entry_thunks (gfc_namespace * ns)
1600 {
1601   gfc_formal_arglist *formal;
1602   gfc_formal_arglist *thunk_formal;
1603   gfc_entry_list *el;
1604   gfc_symbol *thunk_sym;
1605   stmtblock_t body;
1606   tree thunk_fndecl;
1607   tree args;
1608   tree string_args;
1609   tree tmp;
1610   locus old_loc;
1611
1612   /* This should always be a toplevel function.  */
1613   gcc_assert (current_function_decl == NULL_TREE);
1614
1615   gfc_get_backend_locus (&old_loc);
1616   for (el = ns->entries; el; el = el->next)
1617     {
1618       thunk_sym = el->sym;
1619
1620       build_function_decl (thunk_sym);
1621       create_function_arglist (thunk_sym);
1622
1623       trans_function_start (thunk_sym);
1624
1625       thunk_fndecl = thunk_sym->backend_decl;
1626
1627       gfc_start_block (&body);
1628
1629       /* Pass extra parameter identifying this entry point.  */
1630       tmp = build_int_cst (gfc_array_index_type, el->id);
1631       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1632       string_args = NULL_TREE;
1633
1634       if (thunk_sym->attr.function)
1635         {
1636           if (gfc_return_by_reference (ns->proc_name))
1637             {
1638               tree ref = DECL_ARGUMENTS (current_function_decl);
1639               args = tree_cons (NULL_TREE, ref, args);
1640               if (ns->proc_name->ts.type == BT_CHARACTER)
1641                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1642                                   args);
1643             }
1644         }
1645
1646       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1647         {
1648           /* Ignore alternate returns.  */
1649           if (formal->sym == NULL)
1650             continue;
1651
1652           /* We don't have a clever way of identifying arguments, so resort to
1653              a brute-force search.  */
1654           for (thunk_formal = thunk_sym->formal;
1655                thunk_formal;
1656                thunk_formal = thunk_formal->next)
1657             {
1658               if (thunk_formal->sym == formal->sym)
1659                 break;
1660             }
1661
1662           if (thunk_formal)
1663             {
1664               /* Pass the argument.  */
1665               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1666               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1667                                 args);
1668               if (formal->sym->ts.type == BT_CHARACTER)
1669                 {
1670                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1671                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1672                 }
1673             }
1674           else
1675             {
1676               /* Pass NULL for a missing argument.  */
1677               args = tree_cons (NULL_TREE, null_pointer_node, args);
1678               if (formal->sym->ts.type == BT_CHARACTER)
1679                 {
1680                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1681                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1682                 }
1683             }
1684         }
1685
1686       /* Call the master function.  */
1687       args = nreverse (args);
1688       args = chainon (args, nreverse (string_args));
1689       tmp = ns->proc_name->backend_decl;
1690       tmp = build_function_call_expr (tmp, args);
1691       if (ns->proc_name->attr.mixed_entry_master)
1692         {
1693           tree union_decl, field;
1694           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1695
1696           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1697                                    TREE_TYPE (master_type));
1698           DECL_ARTIFICIAL (union_decl) = 1;
1699           DECL_EXTERNAL (union_decl) = 0;
1700           TREE_PUBLIC (union_decl) = 0;
1701           TREE_USED (union_decl) = 1;
1702           layout_decl (union_decl, 0);
1703           pushdecl (union_decl);
1704
1705           DECL_CONTEXT (union_decl) = current_function_decl;
1706           tmp = build2 (MODIFY_EXPR,
1707                         TREE_TYPE (union_decl),
1708                         union_decl, tmp);
1709           gfc_add_expr_to_block (&body, tmp);
1710
1711           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1712                field; field = TREE_CHAIN (field))
1713             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1714                 thunk_sym->result->name) == 0)
1715               break;
1716           gcc_assert (field != NULL_TREE);
1717           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1718                         NULL_TREE);
1719           tmp = build2 (MODIFY_EXPR,
1720                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1721                         DECL_RESULT (current_function_decl), tmp);
1722           tmp = build1_v (RETURN_EXPR, tmp);
1723         }
1724       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1725                != void_type_node)
1726         {
1727           tmp = build2 (MODIFY_EXPR,
1728                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1729                         DECL_RESULT (current_function_decl), tmp);
1730           tmp = build1_v (RETURN_EXPR, tmp);
1731         }
1732       gfc_add_expr_to_block (&body, tmp);
1733
1734       /* Finish off this function and send it for code generation.  */
1735       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1736       poplevel (1, 0, 1);
1737       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1738
1739       /* Output the GENERIC tree.  */
1740       dump_function (TDI_original, thunk_fndecl);
1741
1742       /* Store the end of the function, so that we get good line number
1743          info for the epilogue.  */
1744       cfun->function_end_locus = input_location;
1745
1746       /* We're leaving the context of this function, so zap cfun.
1747          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1748          tree_rest_of_compilation.  */
1749       set_cfun (NULL);
1750
1751       current_function_decl = NULL_TREE;
1752
1753       gfc_gimplify_function (thunk_fndecl);
1754       cgraph_finalize_function (thunk_fndecl, false);
1755
1756       /* We share the symbols in the formal argument list with other entry
1757          points and the master function.  Clear them so that they are
1758          recreated for each function.  */
1759       for (formal = thunk_sym->formal; formal; formal = formal->next)
1760         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1761           {
1762             formal->sym->backend_decl = NULL_TREE;
1763             if (formal->sym->ts.type == BT_CHARACTER)
1764               formal->sym->ts.cl->backend_decl = NULL_TREE;
1765           }
1766
1767       if (thunk_sym->attr.function)
1768         {
1769           if (thunk_sym->ts.type == BT_CHARACTER)
1770             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1771           if (thunk_sym->result->ts.type == BT_CHARACTER)
1772             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1773         }
1774     }
1775
1776   gfc_set_backend_locus (&old_loc);
1777 }
1778
1779
1780 /* Create a decl for a function, and create any thunks for alternate entry
1781    points.  */
1782
1783 void
1784 gfc_create_function_decl (gfc_namespace * ns)
1785 {
1786   /* Create a declaration for the master function.  */
1787   build_function_decl (ns->proc_name);
1788
1789   /* Compile the entry thunks.  */
1790   if (ns->entries)
1791     build_entry_thunks (ns);
1792
1793   /* Now create the read argument list.  */
1794   create_function_arglist (ns->proc_name);
1795 }
1796
1797 /* Return the decl used to hold the function return value.  If
1798    parent_flag is set, the context is the parent_scope.  */
1799
1800 tree
1801 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1802 {
1803   tree decl;
1804   tree length;
1805   tree this_fake_result_decl;
1806   tree this_function_decl;
1807
1808   char name[GFC_MAX_SYMBOL_LEN + 10];
1809
1810   if (parent_flag)
1811     {
1812       this_fake_result_decl = parent_fake_result_decl;
1813       this_function_decl = DECL_CONTEXT (current_function_decl);
1814     }
1815   else
1816     {
1817       this_fake_result_decl = current_fake_result_decl;
1818       this_function_decl = current_function_decl;
1819     }
1820
1821   if (sym
1822       && sym->ns->proc_name->backend_decl == this_function_decl
1823       && sym->ns->proc_name->attr.entry_master
1824       && sym != sym->ns->proc_name)
1825     {
1826       tree t = NULL, var;
1827       if (this_fake_result_decl != NULL)
1828         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1829           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1830             break;
1831       if (t)
1832         return TREE_VALUE (t);
1833       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1834
1835       if (parent_flag)
1836         this_fake_result_decl = parent_fake_result_decl;
1837       else
1838         this_fake_result_decl = current_fake_result_decl;
1839
1840       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1841         {
1842           tree field;
1843
1844           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1845                field; field = TREE_CHAIN (field))
1846             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1847                 sym->name) == 0)
1848               break;
1849
1850           gcc_assert (field != NULL_TREE);
1851           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1852                          NULL_TREE);
1853         }
1854
1855       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1856       if (parent_flag)
1857         gfc_add_decl_to_parent_function (var);
1858       else
1859         gfc_add_decl_to_function (var);
1860
1861       SET_DECL_VALUE_EXPR (var, decl);
1862       DECL_HAS_VALUE_EXPR_P (var) = 1;
1863       GFC_DECL_RESULT (var) = 1;
1864
1865       TREE_CHAIN (this_fake_result_decl)
1866           = tree_cons (get_identifier (sym->name), var,
1867                        TREE_CHAIN (this_fake_result_decl));
1868       return var;
1869     }
1870
1871   if (this_fake_result_decl != NULL_TREE)
1872     return TREE_VALUE (this_fake_result_decl);
1873
1874   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1875      sym is NULL.  */
1876   if (!sym)
1877     return NULL_TREE;
1878
1879   if (sym->ts.type == BT_CHARACTER)
1880     {
1881       if (sym->ts.cl->backend_decl == NULL_TREE)
1882         length = gfc_create_string_length (sym);
1883       else
1884         length = sym->ts.cl->backend_decl;
1885       if (TREE_CODE (length) == VAR_DECL
1886           && DECL_CONTEXT (length) == NULL_TREE)
1887         gfc_add_decl_to_function (length);
1888     }
1889
1890   if (gfc_return_by_reference (sym))
1891     {
1892       decl = DECL_ARGUMENTS (this_function_decl);
1893
1894       if (sym->ns->proc_name->backend_decl == this_function_decl
1895           && sym->ns->proc_name->attr.entry_master)
1896         decl = TREE_CHAIN (decl);
1897
1898       TREE_USED (decl) = 1;
1899       if (sym->as)
1900         decl = gfc_build_dummy_array_decl (sym, decl);
1901     }
1902   else
1903     {
1904       sprintf (name, "__result_%.20s",
1905                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1906
1907       if (!sym->attr.mixed_entry_master && sym->attr.function)
1908         decl = build_decl (VAR_DECL, get_identifier (name),
1909                            gfc_sym_type (sym));
1910       else
1911         decl = build_decl (VAR_DECL, get_identifier (name),
1912                            TREE_TYPE (TREE_TYPE (this_function_decl)));
1913       DECL_ARTIFICIAL (decl) = 1;
1914       DECL_EXTERNAL (decl) = 0;
1915       TREE_PUBLIC (decl) = 0;
1916       TREE_USED (decl) = 1;
1917       GFC_DECL_RESULT (decl) = 1;
1918       TREE_ADDRESSABLE (decl) = 1;
1919
1920       layout_decl (decl, 0);
1921
1922       if (parent_flag)
1923         gfc_add_decl_to_parent_function (decl);
1924       else
1925         gfc_add_decl_to_function (decl);
1926     }
1927
1928   if (parent_flag)
1929     parent_fake_result_decl = build_tree_list (NULL, decl);
1930   else
1931     current_fake_result_decl = build_tree_list (NULL, decl);
1932
1933   return decl;
1934 }
1935
1936
1937 /* Builds a function decl.  The remaining parameters are the types of the
1938    function arguments.  Negative nargs indicates a varargs function.  */
1939
1940 tree
1941 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1942 {
1943   tree arglist;
1944   tree argtype;
1945   tree fntype;
1946   tree fndecl;
1947   va_list p;
1948   int n;
1949
1950   /* Library functions must be declared with global scope.  */
1951   gcc_assert (current_function_decl == NULL_TREE);
1952
1953   va_start (p, nargs);
1954
1955
1956   /* Create a list of the argument types.  */
1957   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1958     {
1959       argtype = va_arg (p, tree);
1960       arglist = gfc_chainon_list (arglist, argtype);
1961     }
1962
1963   if (nargs >= 0)
1964     {
1965       /* Terminate the list.  */
1966       arglist = gfc_chainon_list (arglist, void_type_node);
1967     }
1968
1969   /* Build the function type and decl.  */
1970   fntype = build_function_type (rettype, arglist);
1971   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1972
1973   /* Mark this decl as external.  */
1974   DECL_EXTERNAL (fndecl) = 1;
1975   TREE_PUBLIC (fndecl) = 1;
1976
1977   va_end (p);
1978
1979   pushdecl (fndecl);
1980
1981   rest_of_decl_compilation (fndecl, 1, 0);
1982
1983   return fndecl;
1984 }
1985
1986 static void
1987 gfc_build_intrinsic_function_decls (void)
1988 {
1989   tree gfc_int4_type_node = gfc_get_int_type (4);
1990   tree gfc_int8_type_node = gfc_get_int_type (8);
1991   tree gfc_int16_type_node = gfc_get_int_type (16);
1992   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1993   tree gfc_real4_type_node = gfc_get_real_type (4);
1994   tree gfc_real8_type_node = gfc_get_real_type (8);
1995   tree gfc_real10_type_node = gfc_get_real_type (10);
1996   tree gfc_real16_type_node = gfc_get_real_type (16);
1997   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1998   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1999   tree gfc_complex10_type_node = gfc_get_complex_type (10);
2000   tree gfc_complex16_type_node = gfc_get_complex_type (16);
2001
2002   /* String functions.  */
2003   gfor_fndecl_compare_string =
2004     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2005                                      integer_type_node, 4,
2006                                      gfc_charlen_type_node, pchar_type_node,
2007                                      gfc_charlen_type_node, pchar_type_node);
2008
2009   gfor_fndecl_concat_string =
2010     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2011                                      void_type_node,
2012                                      6,
2013                                      gfc_charlen_type_node, pchar_type_node,
2014                                      gfc_charlen_type_node, pchar_type_node,
2015                                      gfc_charlen_type_node, pchar_type_node);
2016
2017   gfor_fndecl_string_len_trim =
2018     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2019                                      gfc_int4_type_node,
2020                                      2, gfc_charlen_type_node,
2021                                      pchar_type_node);
2022
2023   gfor_fndecl_string_index =
2024     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2025                                      gfc_int4_type_node,
2026                                      5, gfc_charlen_type_node, pchar_type_node,
2027                                      gfc_charlen_type_node, pchar_type_node,
2028                                      gfc_logical4_type_node);
2029
2030   gfor_fndecl_string_scan =
2031     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2032                                      gfc_int4_type_node,
2033                                      5, gfc_charlen_type_node, pchar_type_node,
2034                                      gfc_charlen_type_node, pchar_type_node,
2035                                      gfc_logical4_type_node);
2036
2037   gfor_fndecl_string_verify =
2038     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2039                                      gfc_int4_type_node,
2040                                      5, gfc_charlen_type_node, pchar_type_node,
2041                                      gfc_charlen_type_node, pchar_type_node,
2042                                      gfc_logical4_type_node);
2043
2044   gfor_fndecl_string_trim =
2045     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2046                                      void_type_node,
2047                                      4,
2048                                      build_pointer_type (gfc_charlen_type_node),
2049                                      ppvoid_type_node,
2050                                      gfc_charlen_type_node,
2051                                      pchar_type_node);
2052
2053   gfor_fndecl_string_minmax =
2054     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2055                                      void_type_node, -4,
2056                                      build_pointer_type (gfc_charlen_type_node),
2057                                      ppvoid_type_node, integer_type_node,
2058                                      integer_type_node);
2059
2060   gfor_fndecl_ttynam =
2061     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2062                                      void_type_node,
2063                                      3,
2064                                      pchar_type_node,
2065                                      gfc_charlen_type_node,
2066                                      integer_type_node);
2067
2068   gfor_fndecl_fdate =
2069     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2070                                      void_type_node,
2071                                      2,
2072                                      pchar_type_node,
2073                                      gfc_charlen_type_node);
2074
2075   gfor_fndecl_ctime =
2076     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2077                                      void_type_node,
2078                                      3,
2079                                      pchar_type_node,
2080                                      gfc_charlen_type_node,
2081                                      gfc_int8_type_node);
2082
2083   gfor_fndecl_adjustl =
2084     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2085                                      void_type_node,
2086                                      3,
2087                                      pchar_type_node,
2088                                      gfc_charlen_type_node, pchar_type_node);
2089
2090   gfor_fndecl_adjustr =
2091     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2092                                      void_type_node,
2093                                      3,
2094                                      pchar_type_node,
2095                                      gfc_charlen_type_node, pchar_type_node);
2096
2097   gfor_fndecl_si_kind =
2098     gfc_build_library_function_decl (get_identifier
2099                                         (PREFIX("selected_int_kind")),
2100                                      gfc_int4_type_node,
2101                                      1,
2102                                      pvoid_type_node);
2103
2104   gfor_fndecl_sr_kind =
2105     gfc_build_library_function_decl (get_identifier
2106                                         (PREFIX("selected_real_kind")),
2107                                      gfc_int4_type_node,
2108                                      2, pvoid_type_node,
2109                                      pvoid_type_node);
2110
2111   /* Power functions.  */
2112   {
2113     tree ctype, rtype, itype, jtype;
2114     int rkind, ikind, jkind;
2115 #define NIKINDS 3
2116 #define NRKINDS 4
2117     static int ikinds[NIKINDS] = {4, 8, 16};
2118     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2119     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2120
2121     for (ikind=0; ikind < NIKINDS; ikind++)
2122       {
2123         itype = gfc_get_int_type (ikinds[ikind]);
2124
2125         for (jkind=0; jkind < NIKINDS; jkind++)
2126           {
2127             jtype = gfc_get_int_type (ikinds[jkind]);
2128             if (itype && jtype)
2129               {
2130                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2131                         ikinds[jkind]);
2132                 gfor_fndecl_math_powi[jkind][ikind].integer =
2133                   gfc_build_library_function_decl (get_identifier (name),
2134                     jtype, 2, jtype, itype);
2135                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2136               }
2137           }
2138
2139         for (rkind = 0; rkind < NRKINDS; rkind ++)
2140           {
2141             rtype = gfc_get_real_type (rkinds[rkind]);
2142             if (rtype && itype)
2143               {
2144                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2145                         ikinds[ikind]);
2146                 gfor_fndecl_math_powi[rkind][ikind].real =
2147                   gfc_build_library_function_decl (get_identifier (name),
2148                     rtype, 2, rtype, itype);
2149                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2150               }
2151
2152             ctype = gfc_get_complex_type (rkinds[rkind]);
2153             if (ctype && itype)
2154               {
2155                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2156                         ikinds[ikind]);
2157                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2158                   gfc_build_library_function_decl (get_identifier (name),
2159                     ctype, 2,ctype, itype);
2160                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2161               }
2162           }
2163       }
2164 #undef NIKINDS
2165 #undef NRKINDS
2166   }
2167
2168   gfor_fndecl_math_cpowf =
2169     gfc_build_library_function_decl (get_identifier ("cpowf"),
2170                                      gfc_complex4_type_node,
2171                                      1, gfc_complex4_type_node);
2172   gfor_fndecl_math_cpow =
2173     gfc_build_library_function_decl (get_identifier ("cpow"),
2174                                      gfc_complex8_type_node,
2175                                      1, gfc_complex8_type_node);
2176   if (gfc_complex10_type_node)
2177     gfor_fndecl_math_cpowl10 =
2178       gfc_build_library_function_decl (get_identifier ("cpowl"),
2179                                        gfc_complex10_type_node, 1,
2180                                        gfc_complex10_type_node);
2181   if (gfc_complex16_type_node)
2182     gfor_fndecl_math_cpowl16 =
2183       gfc_build_library_function_decl (get_identifier ("cpowl"),
2184                                        gfc_complex16_type_node, 1,
2185                                        gfc_complex16_type_node);
2186
2187   gfor_fndecl_math_ishftc4 =
2188     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2189                                      gfc_int4_type_node,
2190                                      3, gfc_int4_type_node,
2191                                      gfc_int4_type_node, gfc_int4_type_node);
2192   gfor_fndecl_math_ishftc8 =
2193     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2194                                      gfc_int8_type_node,
2195                                      3, gfc_int8_type_node,
2196                                      gfc_int4_type_node, gfc_int4_type_node);
2197   if (gfc_int16_type_node)
2198     gfor_fndecl_math_ishftc16 =
2199       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2200                                        gfc_int16_type_node, 3,
2201                                        gfc_int16_type_node,
2202                                        gfc_int4_type_node,
2203                                        gfc_int4_type_node);
2204
2205   gfor_fndecl_math_exponent4 =
2206     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2207                                      gfc_int4_type_node,
2208                                      1, gfc_real4_type_node);
2209   gfor_fndecl_math_exponent8 =
2210     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2211                                      gfc_int4_type_node,
2212                                      1, gfc_real8_type_node);
2213   if (gfc_real10_type_node)
2214     gfor_fndecl_math_exponent10 =
2215       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2216                                        gfc_int4_type_node, 1,
2217                                        gfc_real10_type_node);
2218   if (gfc_real16_type_node)
2219     gfor_fndecl_math_exponent16 =
2220       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2221                                        gfc_int4_type_node, 1,
2222                                        gfc_real16_type_node);
2223
2224   /* BLAS functions.  */
2225   {
2226     tree pint = build_pointer_type (integer_type_node);
2227     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2228     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2229     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2230     tree pz = build_pointer_type
2231                 (gfc_get_complex_type (gfc_default_double_kind));
2232
2233     gfor_fndecl_sgemm = gfc_build_library_function_decl
2234                           (get_identifier
2235                              (gfc_option.flag_underscoring ? "sgemm_"
2236                                                            : "sgemm"),
2237                            void_type_node, 15, pchar_type_node,
2238                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2239                            ps, pint, ps, ps, pint, integer_type_node,
2240                            integer_type_node);
2241     gfor_fndecl_dgemm = gfc_build_library_function_decl
2242                           (get_identifier
2243                              (gfc_option.flag_underscoring ? "dgemm_"
2244                                                            : "dgemm"),
2245                            void_type_node, 15, pchar_type_node,
2246                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2247                            pd, pint, pd, pd, pint, integer_type_node,
2248                            integer_type_node);
2249     gfor_fndecl_cgemm = gfc_build_library_function_decl
2250                           (get_identifier
2251                              (gfc_option.flag_underscoring ? "cgemm_"
2252                                                            : "cgemm"),
2253                            void_type_node, 15, pchar_type_node,
2254                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2255                            pc, pint, pc, pc, pint, integer_type_node,
2256                            integer_type_node);
2257     gfor_fndecl_zgemm = gfc_build_library_function_decl
2258                           (get_identifier
2259                              (gfc_option.flag_underscoring ? "zgemm_"
2260                                                            : "zgemm"),
2261                            void_type_node, 15, pchar_type_node,
2262                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2263                            pz, pint, pz, pz, pint, integer_type_node,
2264                            integer_type_node);
2265   }
2266
2267   /* Other functions.  */
2268   gfor_fndecl_size0 =
2269     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2270                                      gfc_array_index_type,
2271                                      1, pvoid_type_node);
2272   gfor_fndecl_size1 =
2273     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2274                                      gfc_array_index_type,
2275                                      2, pvoid_type_node,
2276                                      gfc_array_index_type);
2277
2278   gfor_fndecl_iargc =
2279     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2280                                      gfc_int4_type_node,
2281                                      0);
2282 }
2283
2284
2285 /* Make prototypes for runtime library functions.  */
2286
2287 void
2288 gfc_build_builtin_function_decls (void)
2289 {
2290   tree gfc_int4_type_node = gfc_get_int_type (4);
2291
2292   gfor_fndecl_stop_numeric =
2293     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2294                                      void_type_node, 1, gfc_int4_type_node);
2295   /* Stop doesn't return.  */
2296   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2297
2298   gfor_fndecl_stop_string =
2299     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2300                                      void_type_node, 2, pchar_type_node,
2301                                      gfc_int4_type_node);
2302   /* Stop doesn't return.  */
2303   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2304
2305   gfor_fndecl_pause_numeric =
2306     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2307                                      void_type_node, 1, gfc_int4_type_node);
2308
2309   gfor_fndecl_pause_string =
2310     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2311                                      void_type_node, 2, pchar_type_node,
2312                                      gfc_int4_type_node);
2313
2314   gfor_fndecl_select_string =
2315     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2316                                      integer_type_node, 0);
2317
2318   gfor_fndecl_runtime_error =
2319     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2320                                      void_type_node, -1, pchar_type_node);
2321   /* The runtime_error function does not return.  */
2322   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2323
2324   gfor_fndecl_runtime_error_at =
2325     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2326                                      void_type_node, -2, pchar_type_node,
2327                                      pchar_type_node);
2328   /* The runtime_error_at function does not return.  */
2329   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2330
2331   gfor_fndecl_generate_error =
2332     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2333                                      void_type_node, 3, pvoid_type_node,
2334                                      integer_type_node, pchar_type_node);
2335
2336   gfor_fndecl_os_error =
2337     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2338                                      void_type_node, 1, pchar_type_node);
2339   /* The runtime_error function does not return.  */
2340   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2341
2342   gfor_fndecl_set_fpe =
2343     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2344                                     void_type_node, 1, integer_type_node);
2345
2346   /* Keep the array dimension in sync with the call, later in this file.  */
2347   gfor_fndecl_set_options =
2348     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2349                                     void_type_node, 2, integer_type_node,
2350                                     pvoid_type_node);
2351
2352   gfor_fndecl_set_convert =
2353     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2354                                      void_type_node, 1, integer_type_node);
2355
2356   gfor_fndecl_set_record_marker =
2357     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2358                                      void_type_node, 1, integer_type_node);
2359
2360   gfor_fndecl_set_max_subrecord_length =
2361     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2362                                      void_type_node, 1, integer_type_node);
2363
2364   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2365         get_identifier (PREFIX("internal_pack")),
2366         pvoid_type_node, 1, pvoid_type_node);
2367
2368   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2369         get_identifier (PREFIX("internal_unpack")),
2370         pvoid_type_node, 1, pvoid_type_node);
2371
2372   gfor_fndecl_associated =
2373     gfc_build_library_function_decl (
2374                                      get_identifier (PREFIX("associated")),
2375                                      integer_type_node, 2, ppvoid_type_node,
2376                                      ppvoid_type_node);
2377
2378   gfc_build_intrinsic_function_decls ();
2379   gfc_build_intrinsic_lib_fndecls ();
2380   gfc_build_io_library_fndecls ();
2381 }
2382
2383
2384 /* Evaluate the length of dummy character variables.  */
2385
2386 static tree
2387 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2388 {
2389   stmtblock_t body;
2390
2391   gfc_finish_decl (cl->backend_decl);
2392
2393   gfc_start_block (&body);
2394
2395   /* Evaluate the string length expression.  */
2396   gfc_conv_string_length (cl, &body);
2397
2398   gfc_trans_vla_type_sizes (sym, &body);
2399
2400   gfc_add_expr_to_block (&body, fnbody);
2401   return gfc_finish_block (&body);
2402 }
2403
2404
2405 /* Allocate and cleanup an automatic character variable.  */
2406
2407 static tree
2408 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2409 {
2410   stmtblock_t body;
2411   tree decl;
2412   tree tmp;
2413
2414   gcc_assert (sym->backend_decl);
2415   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2416
2417   gfc_start_block (&body);
2418
2419   /* Evaluate the string length expression.  */
2420   gfc_conv_string_length (sym->ts.cl, &body);
2421
2422   gfc_trans_vla_type_sizes (sym, &body);
2423
2424   decl = sym->backend_decl;
2425
2426   /* Emit a DECL_EXPR for this variable, which will cause the
2427      gimplifier to allocate storage, and all that good stuff.  */
2428   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2429   gfc_add_expr_to_block (&body, tmp);
2430
2431   gfc_add_expr_to_block (&body, fnbody);
2432   return gfc_finish_block (&body);
2433 }
2434
2435 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2436
2437 static tree
2438 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2439 {
2440   stmtblock_t body;
2441
2442   gcc_assert (sym->backend_decl);
2443   gfc_start_block (&body);
2444
2445   /* Set the initial value to length. See the comments in
2446      function gfc_add_assign_aux_vars in this file.  */
2447   gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2448                        build_int_cst (NULL_TREE, -2));
2449
2450   gfc_add_expr_to_block (&body, fnbody);
2451   return gfc_finish_block (&body);
2452 }
2453
2454 static void
2455 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2456 {
2457   tree t = *tp, var, val;
2458
2459   if (t == NULL || t == error_mark_node)
2460     return;
2461   if (TREE_CONSTANT (t) || DECL_P (t))
2462     return;
2463
2464   if (TREE_CODE (t) == SAVE_EXPR)
2465     {
2466       if (SAVE_EXPR_RESOLVED_P (t))
2467         {
2468           *tp = TREE_OPERAND (t, 0);
2469           return;
2470         }
2471       val = TREE_OPERAND (t, 0);
2472     }
2473   else
2474     val = t;
2475
2476   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2477   gfc_add_decl_to_function (var);
2478   gfc_add_modify_expr (body, var, val);
2479   if (TREE_CODE (t) == SAVE_EXPR)
2480     TREE_OPERAND (t, 0) = var;
2481   *tp = var;
2482 }
2483
2484 static void
2485 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2486 {
2487   tree t;
2488
2489   if (type == NULL || type == error_mark_node)
2490     return;
2491
2492   type = TYPE_MAIN_VARIANT (type);
2493
2494   if (TREE_CODE (type) == INTEGER_TYPE)
2495     {
2496       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2497       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2498
2499       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2500         {
2501           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2502           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2503         }
2504     }
2505   else if (TREE_CODE (type) == ARRAY_TYPE)
2506     {
2507       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2508       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2509       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2510       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2511
2512       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2513         {
2514           TYPE_SIZE (t) = TYPE_SIZE (type);
2515           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2516         }
2517     }
2518 }
2519
2520 /* Make sure all type sizes and array domains are either constant,
2521    or variable or parameter decls.  This is a simplified variant
2522    of gimplify_type_sizes, but we can't use it here, as none of the
2523    variables in the expressions have been gimplified yet.
2524    As type sizes and domains for various variable length arrays
2525    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2526    time, without this routine gimplify_type_sizes in the middle-end
2527    could result in the type sizes being gimplified earlier than where
2528    those variables are initialized.  */
2529
2530 void
2531 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2532 {
2533   tree type = TREE_TYPE (sym->backend_decl);
2534
2535   if (TREE_CODE (type) == FUNCTION_TYPE
2536       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2537     {
2538       if (! current_fake_result_decl)
2539         return;
2540
2541       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2542     }
2543
2544   while (POINTER_TYPE_P (type))
2545     type = TREE_TYPE (type);
2546
2547   if (GFC_DESCRIPTOR_TYPE_P (type))
2548     {
2549       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2550
2551       while (POINTER_TYPE_P (etype))
2552         etype = TREE_TYPE (etype);
2553
2554       gfc_trans_vla_type_sizes_1 (etype, body);
2555     }
2556
2557   gfc_trans_vla_type_sizes_1 (type, body);
2558 }
2559
2560
2561 /* Generate function entry and exit code, and add it to the function body.
2562    This includes:
2563     Allocation and initialization of array variables.
2564     Allocation of character string variables.
2565     Initialization and possibly repacking of dummy arrays.
2566     Initialization of ASSIGN statement auxiliary variable.  */
2567
2568 static tree
2569 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2570 {
2571   locus loc;
2572   gfc_symbol *sym;
2573   gfc_formal_arglist *f;
2574   stmtblock_t body;
2575   bool seen_trans_deferred_array = false;
2576
2577   /* Deal with implicit return variables.  Explicit return variables will
2578      already have been added.  */
2579   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2580     {
2581       if (!current_fake_result_decl)
2582         {
2583           gfc_entry_list *el = NULL;
2584           if (proc_sym->attr.entry_master)
2585             {
2586               for (el = proc_sym->ns->entries; el; el = el->next)
2587                 if (el->sym != el->sym->result)
2588                   break;
2589             }
2590           if (el == NULL)
2591             warning (0, "Function does not return a value");
2592         }
2593       else if (proc_sym->as)
2594         {
2595           tree result = TREE_VALUE (current_fake_result_decl);
2596           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2597
2598           /* An automatic character length, pointer array result.  */
2599           if (proc_sym->ts.type == BT_CHARACTER
2600                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2601             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2602                                                 fnbody);
2603         }
2604       else if (proc_sym->ts.type == BT_CHARACTER)
2605         {
2606           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2607             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2608                                                 fnbody);
2609         }
2610       else
2611         gcc_assert (gfc_option.flag_f2c
2612                     && proc_sym->ts.type == BT_COMPLEX);
2613     }
2614
2615   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2616     {
2617       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2618                                    && sym->ts.derived->attr.alloc_comp;
2619       if (sym->attr.dimension)
2620         {
2621           switch (sym->as->type)
2622             {
2623             case AS_EXPLICIT:
2624               if (sym->attr.dummy || sym->attr.result)
2625                 fnbody =
2626                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2627               else if (sym->attr.pointer || sym->attr.allocatable)
2628                 {
2629                   if (TREE_STATIC (sym->backend_decl))
2630                     gfc_trans_static_array_pointer (sym);
2631                   else
2632                     {
2633                       seen_trans_deferred_array = true;
2634                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2635                     }
2636                 }
2637               else
2638                 {
2639                   if (sym_has_alloc_comp)
2640                     {
2641                       seen_trans_deferred_array = true;
2642                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2643                     }
2644
2645                   gfc_get_backend_locus (&loc);
2646                   gfc_set_backend_locus (&sym->declared_at);
2647                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2648                       sym, fnbody);
2649                   gfc_set_backend_locus (&loc);
2650                 }
2651               break;
2652
2653             case AS_ASSUMED_SIZE:
2654               /* Must be a dummy parameter.  */
2655               gcc_assert (sym->attr.dummy);
2656
2657               /* We should always pass assumed size arrays the g77 way.  */
2658               fnbody = gfc_trans_g77_array (sym, fnbody);
2659               break;
2660
2661             case AS_ASSUMED_SHAPE:
2662               /* Must be a dummy parameter.  */
2663               gcc_assert (sym->attr.dummy);
2664
2665               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2666                                                    fnbody);
2667               break;
2668
2669             case AS_DEFERRED:
2670               seen_trans_deferred_array = true;
2671               fnbody = gfc_trans_deferred_array (sym, fnbody);
2672               break;
2673
2674             default:
2675               gcc_unreachable ();
2676             }
2677           if (sym_has_alloc_comp && !seen_trans_deferred_array)
2678             fnbody = gfc_trans_deferred_array (sym, fnbody);
2679         }
2680       else if (sym_has_alloc_comp)
2681         fnbody = gfc_trans_deferred_array (sym, fnbody);
2682       else if (sym->ts.type == BT_CHARACTER)
2683         {
2684           gfc_get_backend_locus (&loc);
2685           gfc_set_backend_locus (&sym->declared_at);
2686           if (sym->attr.dummy || sym->attr.result)
2687             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2688           else
2689             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2690           gfc_set_backend_locus (&loc);
2691         }
2692       else if (sym->attr.assign)
2693         {
2694           gfc_get_backend_locus (&loc);
2695           gfc_set_backend_locus (&sym->declared_at);
2696           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2697           gfc_set_backend_locus (&loc);
2698         }
2699       else
2700         gcc_unreachable ();
2701     }
2702
2703   gfc_init_block (&body);
2704
2705   for (f = proc_sym->formal; f; f = f->next)
2706     {
2707       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2708         {
2709           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2710           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2711             gfc_trans_vla_type_sizes (f->sym, &body);
2712         }
2713
2714       /* If an INTENT(OUT) dummy of derived type has a default
2715          initializer, it must be initialized here.  */
2716       if (f->sym && f->sym->attr.intent == INTENT_OUT
2717             && f->sym->ts.type == BT_DERIVED
2718             && !f->sym->ts.derived->attr.alloc_comp
2719             && f->sym->value)
2720         {
2721           gfc_expr *tmpe;
2722           tree tmp, present;
2723           gcc_assert (!f->sym->attr.allocatable);
2724           gfc_set_sym_referenced (f->sym);
2725           tmpe = gfc_lval_expr_from_sym (f->sym);
2726           tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
2727
2728           present = gfc_conv_expr_present (f->sym);
2729           tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2730                         tmp, build_empty_stmt ());
2731           gfc_add_expr_to_block (&body, tmp);
2732           gfc_free_expr (tmpe);
2733         }
2734     }
2735
2736   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2737       && current_fake_result_decl != NULL)
2738     {
2739       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2740       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2741         gfc_trans_vla_type_sizes (proc_sym, &body);
2742     }
2743
2744   gfc_add_expr_to_block (&body, fnbody);
2745   return gfc_finish_block (&body);
2746 }
2747
2748
2749 /* Output an initialized decl for a module variable.  */
2750
2751 static void
2752 gfc_create_module_variable (gfc_symbol * sym)
2753 {
2754   tree decl;
2755
2756   /* Module functions with alternate entries are dealt with later and
2757      would get caught by the next condition.  */
2758   if (sym->attr.entry)
2759     return;
2760
2761   /* Make sure we convert the types of the derived types from iso_c_binding
2762      into (void *).  */
2763   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2764       && sym->ts.type == BT_DERIVED)
2765     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2766
2767   /* Only output variables and array valued parameters.  */
2768   if (sym->attr.flavor != FL_VARIABLE
2769       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2770     return;
2771
2772   /* Don't generate variables from other modules. Variables from
2773      COMMONs will already have been generated.  */
2774   if (sym->attr.use_assoc || sym->attr.in_common)
2775     return;
2776
2777   /* Equivalenced variables arrive here after creation.  */
2778   if (sym->backend_decl
2779         && (sym->equiv_built || sym->attr.in_equivalence))
2780       return;
2781
2782   if (sym->backend_decl)
2783     internal_error ("backend decl for module variable %s already exists",
2784                     sym->name);
2785
2786   /* We always want module variables to be created.  */
2787   sym->attr.referenced = 1;
2788   /* Create the decl.  */
2789   decl = gfc_get_symbol_decl (sym);
2790
2791   /* Create the variable.  */
2792   pushdecl (decl);
2793   rest_of_decl_compilation (decl, 1, 0);
2794
2795   /* Also add length of strings.  */
2796   if (sym->ts.type == BT_CHARACTER)
2797     {
2798       tree length;
2799
2800       length = sym->ts.cl->backend_decl;
2801       if (!INTEGER_CST_P (length))
2802         {
2803           pushdecl (length);
2804           rest_of_decl_compilation (length, 1, 0);
2805         }
2806     }
2807 }
2808
2809
2810 /* Generate all the required code for module variables.  */
2811
2812 void
2813 gfc_generate_module_vars (gfc_namespace * ns)
2814 {
2815   module_namespace = ns;
2816
2817   /* Check if the frontend left the namespace in a reasonable state.  */
2818   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2819
2820   /* Generate COMMON blocks.  */
2821   gfc_trans_common (ns);
2822
2823   /* Create decls for all the module variables.  */
2824   gfc_traverse_ns (ns, gfc_create_module_variable);
2825 }
2826
2827 static void
2828 gfc_generate_contained_functions (gfc_namespace * parent)
2829 {
2830   gfc_namespace *ns;
2831
2832   /* We create all the prototypes before generating any code.  */
2833   for (ns = parent->contained; ns; ns = ns->sibling)
2834     {
2835       /* Skip namespaces from used modules.  */
2836       if (ns->parent != parent)
2837         continue;
2838
2839       gfc_create_function_decl (ns);
2840     }
2841
2842   for (ns = parent->contained; ns; ns = ns->sibling)
2843     {
2844       /* Skip namespaces from used modules.  */
2845       if (ns->parent != parent)
2846         continue;
2847
2848       gfc_generate_function_code (ns);
2849     }
2850 }
2851
2852
2853 /* Drill down through expressions for the array specification bounds and
2854    character length calling generate_local_decl for all those variables
2855    that have not already been declared.  */
2856
2857 static void
2858 generate_local_decl (gfc_symbol *);
2859
2860 static void
2861 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2862 {
2863   gfc_actual_arglist *arg;
2864   gfc_ref *ref;
2865   int i;
2866
2867   if (e == NULL)
2868     return;
2869
2870   switch (e->expr_type)
2871     {
2872     case EXPR_FUNCTION:
2873       for (arg = e->value.function.actual; arg; arg = arg->next)
2874         generate_expr_decls (sym, arg->expr);
2875       break;
2876
2877     /* If the variable is not the same as the dependent, 'sym', and
2878        it is not marked as being declared and it is in the same
2879        namespace as 'sym', add it to the local declarations.  */
2880     case EXPR_VARIABLE:
2881       if (sym == e->symtree->n.sym
2882             || e->symtree->n.sym->mark
2883             || e->symtree->n.sym->ns != sym->ns)
2884         return;
2885
2886       generate_local_decl (e->symtree->n.sym);
2887       break;
2888
2889     case EXPR_OP:
2890       generate_expr_decls (sym, e->value.op.op1);
2891       generate_expr_decls (sym, e->value.op.op2);
2892       break;
2893
2894     default:
2895       break;
2896     }
2897
2898   if (e->ref)
2899     {
2900       for (ref = e->ref; ref; ref = ref->next)
2901         {
2902           switch (ref->type)
2903             {
2904             case REF_ARRAY:
2905               for (i = 0; i < ref->u.ar.dimen; i++)
2906                 {
2907                   generate_expr_decls (sym, ref->u.ar.start[i]);
2908                   generate_expr_decls (sym, ref->u.ar.end[i]);
2909                   generate_expr_decls (sym, ref->u.ar.stride[i]);
2910                 }
2911               break;
2912
2913             case REF_SUBSTRING:
2914               generate_expr_decls (sym, ref->u.ss.start);
2915               generate_expr_decls (sym, ref->u.ss.end);
2916               break;
2917
2918             case REF_COMPONENT:
2919               if (ref->u.c.component->ts.type == BT_CHARACTER
2920                     && ref->u.c.component->ts.cl->length->expr_type
2921                                                 != EXPR_CONSTANT)
2922                 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2923
2924               if (ref->u.c.component->as)
2925                 for (i = 0; i < ref->u.c.component->as->rank; i++)
2926                   {
2927                     generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2928                     generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2929                   }
2930               break;
2931             }
2932         }
2933     }
2934 }
2935
2936
2937 /* Check for dependencies in the character length and array spec.  */
2938
2939 static void
2940 generate_dependency_declarations (gfc_symbol *sym)
2941 {
2942   int i;
2943
2944   if (sym->ts.type == BT_CHARACTER
2945         && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2946     generate_expr_decls (sym, sym->ts.cl->length);
2947
2948   if (sym->as && sym->as->rank)
2949     {
2950       for (i = 0; i < sym->as->rank; i++)
2951         {
2952           generate_expr_decls (sym, sym->as->lower[i]);
2953           generate_expr_decls (sym, sym->as->upper[i]);
2954         }
2955     }
2956 }
2957
2958
2959 /* Generate decls for all local variables.  We do this to ensure correct
2960    handling of expressions which only appear in the specification of
2961    other functions.  */
2962
2963 static void
2964 generate_local_decl (gfc_symbol * sym)
2965 {
2966   if (sym->attr.flavor == FL_VARIABLE)
2967     {
2968       /* Check for dependencies in the array specification and string
2969         length, adding the necessary declarations to the function.  We
2970         mark the symbol now, as well as in traverse_ns, to prevent
2971         getting stuck in a circular dependency.  */
2972       sym->mark = 1;
2973       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2974         generate_dependency_declarations (sym);
2975
2976       if (sym->attr.referenced)
2977         gfc_get_symbol_decl (sym);
2978       /* INTENT(out) dummy arguments are likely meant to be set.  */
2979       else if (warn_unused_variable
2980                && sym->attr.dummy
2981                && sym->attr.intent == INTENT_OUT)
2982         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
2983                      sym->name, &sym->declared_at);
2984       /* Specific warning for unused dummy arguments. */
2985       else if (warn_unused_variable && sym->attr.dummy)
2986         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
2987                      &sym->declared_at);
2988       /* Warn for unused variables, but not if they're inside a common
2989          block or are use-associated.  */
2990       else if (warn_unused_variable
2991                && !(sym->attr.in_common || sym->attr.use_assoc))
2992         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
2993                      &sym->declared_at);
2994       /* For variable length CHARACTER parameters, the PARM_DECL already
2995          references the length variable, so force gfc_get_symbol_decl
2996          even when not referenced.  If optimize > 0, it will be optimized
2997          away anyway.  But do this only after emitting -Wunused-parameter
2998          warning if requested.  */
2999       if (sym->attr.dummy && ! sym->attr.referenced
3000           && sym->ts.type == BT_CHARACTER
3001           && sym->ts.cl->backend_decl != NULL
3002           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3003         {
3004           sym->attr.referenced = 1;
3005           gfc_get_symbol_decl (sym);
3006         }
3007
3008       /* We do not want the middle-end to warn about unused parameters
3009          as this was already done above.  */
3010       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3011           TREE_NO_WARNING(sym->backend_decl) = 1;
3012     }
3013   else if (sym->attr.flavor == FL_PARAMETER)
3014     {
3015       if (warn_unused_parameter
3016            && !sym->attr.referenced
3017            && !sym->attr.use_assoc)
3018         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3019                      &sym->declared_at);
3020     }
3021
3022   if (sym->attr.dummy == 1)
3023     {
3024       /* Modify the tree type for scalar character dummy arguments of bind(c)
3025          procedures if they are passed by value.  The tree type for them will
3026          be promoted to INTEGER_TYPE for the middle end, which appears to be
3027          what C would do with characters passed by-value.  The value attribute
3028          implies the dummy is a scalar.  */
3029       if (sym->attr.value == 1 && sym->backend_decl != NULL
3030           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3031           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3032         gfc_conv_scalar_char_value (sym, NULL, NULL);
3033     }
3034
3035   /* Make sure we convert the types of the derived types from iso_c_binding
3036      into (void *).  */
3037   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3038       && sym->ts.type == BT_DERIVED)
3039     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3040 }
3041
3042 static void
3043 generate_local_vars (gfc_namespace * ns)
3044 {
3045   gfc_traverse_ns (ns, generate_local_decl);
3046 }
3047
3048
3049 /* Generate a switch statement to jump to the correct entry point.  Also
3050    creates the label decls for the entry points.  */
3051
3052 static tree
3053 gfc_trans_entry_master_switch (gfc_entry_list * el)
3054 {
3055   stmtblock_t block;
3056   tree label;
3057   tree tmp;
3058   tree val;
3059
3060   gfc_init_block (&block);
3061   for (; el; el = el->next)
3062     {
3063       /* Add the case label.  */
3064       label = gfc_build_label_decl (NULL_TREE);
3065       val = build_int_cst (gfc_array_index_type, el->id);
3066       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3067       gfc_add_expr_to_block (&block, tmp);
3068
3069       /* And jump to the actual entry point.  */
3070       label = gfc_build_label_decl (NULL_TREE);
3071       tmp = build1_v (GOTO_EXPR, label);
3072       gfc_add_expr_to_block (&block, tmp);
3073
3074       /* Save the label decl.  */
3075       el->label = label;
3076     }
3077   tmp = gfc_finish_block (&block);
3078   /* The first argument selects the entry point.  */
3079   val = DECL_ARGUMENTS (current_function_decl);
3080   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3081   return tmp;
3082 }
3083
3084
3085 /* Generate code for a function.  */
3086
3087 void
3088 gfc_generate_function_code (gfc_namespace * ns)
3089 {
3090   tree fndecl;
3091   tree old_context;
3092   tree decl;
3093   tree tmp;
3094   tree tmp2;
3095   stmtblock_t block;
3096   stmtblock_t body;
3097   tree result;
3098   gfc_symbol *sym;
3099   int rank;
3100
3101   sym = ns->proc_name;
3102
3103   /* Check that the frontend isn't still using this.  */
3104   gcc_assert (sym->tlink == NULL);
3105   sym->tlink = sym;
3106
3107   /* Create the declaration for functions with global scope.  */
3108   if (!sym->backend_decl)
3109     gfc_create_function_decl (ns);
3110
3111   fndecl = sym->backend_decl;
3112   old_context = current_function_decl;
3113
3114   if (old_context)
3115     {
3116       push_function_context ();
3117       saved_parent_function_decls = saved_function_decls;
3118       saved_function_decls = NULL_TREE;
3119     }
3120
3121   trans_function_start (sym);
3122
3123   gfc_start_block (&block);
3124
3125   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3126     {
3127       /* Copy length backend_decls to all entry point result
3128          symbols.  */
3129       gfc_entry_list *el;
3130       tree backend_decl;
3131
3132       gfc_conv_const_charlen (ns->proc_name->ts.cl);
3133       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3134       for (el = ns->entries; el; el = el->next)
3135         el->sym->result->ts.cl->backend_decl = backend_decl;
3136     }
3137
3138   /* Translate COMMON blocks.  */
3139   gfc_trans_common (ns);
3140
3141   /* Null the parent fake result declaration if this namespace is
3142      a module function or an external procedures.  */
3143   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3144         || ns->parent == NULL)
3145     parent_fake_result_decl = NULL_TREE;
3146
3147   gfc_generate_contained_functions (ns);
3148
3149   generate_local_vars (ns);
3150
3151   /* Keep the parent fake result declaration in module functions
3152      or external procedures.  */
3153   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3154         || ns->parent == NULL)
3155     current_fake_result_decl = parent_fake_result_decl;
3156   else
3157     current_fake_result_decl = NULL_TREE;
3158
3159   current_function_return_label = NULL;
3160
3161   /* Now generate the code for the body of this function.  */
3162   gfc_init_block (&body);
3163
3164   /* If this is the main program, add a call to set_options to set up the
3165      runtime library Fortran language standard parameters.  */
3166   if (sym->attr.is_main_program)
3167     {
3168       tree array_type, array, var;
3169
3170       /* Passing a new option to the library requires four modifications:
3171            + add it to the tree_cons list below
3172            + change the array size in the call to build_array_type
3173            + change the first argument to the library call
3174              gfor_fndecl_set_options
3175            + modify the library (runtime/compile_options.c)!  */
3176       array = tree_cons (NULL_TREE,
3177                          build_int_cst (integer_type_node,
3178                                         gfc_option.warn_std), NULL_TREE);
3179       array = tree_cons (NULL_TREE,
3180                          build_int_cst (integer_type_node,
3181                                         gfc_option.allow_std), array);
3182       array = tree_cons (NULL_TREE,
3183                          build_int_cst (integer_type_node, pedantic), array);
3184       array = tree_cons (NULL_TREE,
3185                          build_int_cst (integer_type_node,
3186                                         gfc_option.flag_dump_core), array);
3187       array = tree_cons (NULL_TREE,
3188                          build_int_cst (integer_type_node,
3189                                         gfc_option.flag_backtrace), array);
3190       array = tree_cons (NULL_TREE,
3191                          build_int_cst (integer_type_node,
3192                                         gfc_option.flag_sign_zero), array);
3193
3194       array = tree_cons (NULL_TREE,
3195                          build_int_cst (integer_type_node,
3196                                         flag_bounds_check), array);
3197
3198       array_type = build_array_type (integer_type_node,
3199                                      build_index_type (build_int_cst (NULL_TREE,
3200                                                                       6)));
3201       array = build_constructor_from_list (array_type, nreverse (array));
3202       TREE_CONSTANT (array) = 1;
3203       TREE_INVARIANT (array) = 1;
3204       TREE_STATIC (array) = 1;
3205
3206       /* Create a static variable to hold the jump table.  */
3207       var = gfc_create_var (array_type, "options");
3208       TREE_CONSTANT (var) = 1;
3209       TREE_INVARIANT (var) = 1;
3210       TREE_STATIC (var) = 1;
3211       TREE_READONLY (var) = 1;
3212       DECL_INITIAL (var) = array;
3213       var = gfc_build_addr_expr (pvoid_type_node, var);
3214
3215       tmp = build_call_expr (gfor_fndecl_set_options, 2,
3216                              build_int_cst (integer_type_node, 7), var);
3217       gfc_add_expr_to_block (&body, tmp);
3218     }
3219
3220   /* If this is the main program and a -ffpe-trap option was provided,
3221      add a call to set_fpe so that the library will raise a FPE when
3222      needed.  */
3223   if (sym->attr.is_main_program && gfc_option.fpe != 0)
3224     {
3225       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3226                              build_int_cst (integer_type_node,
3227                                             gfc_option.fpe));
3228       gfc_add_expr_to_block (&body, tmp);
3229     }
3230
3231   /* If this is the main program and an -fconvert option was provided,
3232      add a call to set_convert.  */
3233
3234   if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3235     {
3236       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3237                              build_int_cst (integer_type_node,
3238                                             gfc_option.convert));
3239       gfc_add_expr_to_block (&body, tmp);
3240     }
3241
3242   /* If this is the main program and an -frecord-marker option was provided,
3243      add a call to set_record_marker.  */
3244
3245   if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3246     {
3247       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3248                              build_int_cst (integer_type_node,
3249                                             gfc_option.record_marker));
3250       gfc_add_expr_to_block (&body, tmp);
3251     }
3252
3253   if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3254     {
3255       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3256                              1,
3257                              build_int_cst (integer_type_node,
3258                                             gfc_option.max_subrecord_length));
3259       gfc_add_expr_to_block (&body, tmp);
3260     }
3261
3262   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3263       && sym->attr.subroutine)
3264     {
3265       tree alternate_return;
3266       alternate_return = gfc_get_fake_result_decl (sym, 0);
3267       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3268     }
3269
3270   if (ns->entries)
3271     {
3272       /* Jump to the correct entry point.  */
3273       tmp = gfc_trans_entry_master_switch (ns->entries);
3274       gfc_add_expr_to_block (&body, tmp);
3275     }
3276
3277   tmp = gfc_trans_code (ns->code);
3278   gfc_add_expr_to_block (&body, tmp);
3279
3280   /* Add a return label if needed.  */
3281   if (current_function_return_label)
3282     {
3283       tmp = build1_v (LABEL_EXPR, current_function_return_label);
3284       gfc_add_expr_to_block (&body, tmp);
3285     }
3286
3287   tmp = gfc_finish_block (&body);
3288   /* Add code to create and cleanup arrays.  */
3289   tmp = gfc_trans_deferred_vars (sym, tmp);
3290
3291   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3292     {
3293       if (sym->attr.subroutine || sym == sym->result)
3294         {
3295           if (current_fake_result_decl != NULL)
3296             result = TREE_VALUE (current_fake_result_decl);
3297           else
3298             result = NULL_TREE;
3299           current_fake_result_decl = NULL_TREE;
3300         }
3301       else
3302         result = sym->result->backend_decl;
3303
3304       if (result != NULL_TREE && sym->attr.function
3305             && sym->ts.type == BT_DERIVED
3306             && sym->ts.derived->attr.alloc_comp
3307             && !sym->attr.pointer)
3308         {
3309           rank = sym->as ? sym->as->rank : 0;
3310           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3311           gfc_add_expr_to_block (&block, tmp2);
3312         }
3313
3314      gfc_add_expr_to_block (&block, tmp);
3315
3316      if (result == NULL_TREE)
3317         warning (0, "Function return value not set");
3318       else
3319         {
3320           /* Set the return value to the dummy result variable.  The
3321              types may be different for scalar default REAL functions
3322              with -ff2c, therefore we have to convert.  */
3323           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3324           tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3325                         DECL_RESULT (fndecl), tmp);
3326           tmp = build1_v (RETURN_EXPR, tmp);
3327           gfc_add_expr_to_block (&block, tmp);
3328         }
3329     }
3330   else
3331     gfc_add_expr_to_block (&block, tmp);
3332
3333
3334   /* Add all the decls we created during processing.  */
3335   decl = saved_function_decls;
3336   while (decl)
3337     {
3338       tree next;
3339
3340       next = TREE_CHAIN (decl);
3341       TREE_CHAIN (decl) = NULL_TREE;
3342       pushdecl (decl);
3343       decl = next;
3344     }
3345   saved_function_decls = NULL_TREE;
3346
3347   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3348
3349   /* Finish off this function and send it for code generation.  */
3350   poplevel (1, 0, 1);
3351   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3352
3353   /* Output the GENERIC tree.  */
3354   dump_function (TDI_original, fndecl);
3355
3356   /* Store the end of the function, so that we get good line number
3357      info for the epilogue.  */
3358   cfun->function_end_locus = input_location;
3359
3360   /* We're leaving the context of this function, so zap cfun.
3361      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3362      tree_rest_of_compilation.  */
3363   set_cfun (NULL);
3364
3365   if (old_context)
3366     {
3367       pop_function_context ();
3368       saved_function_decls = saved_parent_function_decls;
3369     }
3370   current_function_decl = old_context;
3371
3372   if (decl_function_context (fndecl))
3373     /* Register this function with cgraph just far enough to get it
3374        added to our parent's nested function list.  */
3375     (void) cgraph_node (fndecl);
3376   else
3377     {
3378       gfc_gimplify_function (fndecl);
3379       cgraph_finalize_function (fndecl, false);
3380     }
3381 }
3382
3383 void
3384 gfc_generate_constructors (void)
3385 {
3386   gcc_assert (gfc_static_ctors == NULL_TREE);
3387 #if 0
3388   tree fnname;
3389   tree type;
3390   tree fndecl;
3391   tree decl;
3392   tree tmp;
3393
3394   if (gfc_static_ctors == NULL_TREE)
3395     return;
3396
3397   fnname = get_file_function_name ("I");
3398   type = build_function_type (void_type_node,
3399                               gfc_chainon_list (NULL_TREE, void_type_node));
3400
3401   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3402   TREE_PUBLIC (fndecl) = 1;
3403
3404   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3405   DECL_ARTIFICIAL (decl) = 1;
3406   DECL_IGNORED_P (decl) = 1;
3407   DECL_CONTEXT (decl) = fndecl;
3408   DECL_RESULT (fndecl) = decl;
3409
3410   pushdecl (fndecl);
3411
3412   current_function_decl = fndecl;
3413
3414   rest_of_decl_compilation (fndecl, 1, 0);
3415
3416   make_decl_rtl (fndecl);
3417
3418   init_function_start (fndecl);
3419
3420   pushlevel (0);
3421
3422   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3423     {
3424       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3425       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3426     }
3427
3428   poplevel (1, 0, 1);
3429
3430   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3431
3432   free_after_parsing (cfun);
3433   free_after_compilation (cfun);
3434
3435   tree_rest_of_compilation (fndecl);
3436
3437   current_function_decl = NULL_TREE;
3438 #endif
3439 }
3440
3441 /* Translates a BLOCK DATA program unit. This means emitting the
3442    commons contained therein plus their initializations. We also emit
3443    a globally visible symbol to make sure that each BLOCK DATA program
3444    unit remains unique.  */
3445
3446 void
3447 gfc_generate_block_data (gfc_namespace * ns)
3448 {
3449   tree decl;
3450   tree id;
3451
3452   /* Tell the backend the source location of the block data.  */
3453   if (ns->proc_name)
3454     gfc_set_backend_locus (&ns->proc_name->declared_at);
3455   else
3456     gfc_set_backend_locus (&gfc_current_locus);
3457
3458   /* Process the DATA statements.  */
3459   gfc_trans_common (ns);
3460
3461   /* Create a global symbol with the mane of the block data.  This is to
3462      generate linker errors if the same name is used twice.  It is never
3463      really used.  */
3464   if (ns->proc_name)
3465     id = gfc_sym_mangled_function_id (ns->proc_name);
3466   else
3467     id = get_identifier ("__BLOCK_DATA__");
3468
3469   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3470   TREE_PUBLIC (decl) = 1;
3471   TREE_STATIC (decl) = 1;
3472
3473   pushdecl (decl);
3474   rest_of_decl_compilation (decl, 1, 0);
3475 }
3476
3477
3478 #include "gt-fortran-trans-decl.h"