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