gcc/fortran/trans-decl.c

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