gcc/fortran/trans-decl.c

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