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