gcc/fortran/trans-decl.c

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